Hsieh

回復 10# b9208

Rng.AdvancedFilter xlFilterCopy, .Range(.[c3], .[c3].End(xlDown)), CopyTo, False

b9208

回復 11# Hsieh
謝謝Hsieh版主指導
前Hsieh版主協助程式碼採無標題列排序，符合需求，因實際運用標題列是有三列合併的（如下圖）。
今想增加相同資料列，從其第二筆資料開始填滿黃色標示。

下載 (75.84 KB)

2013-3-10 10:45

b9208

回復 9# GBKEE
GBKEE版主您好
依照例子執行OK
但實際運用標題列是有三列合併格的設計（如圖）
非常抱歉沒有說明清楚

下載 (75.84 KB)

2013-3-10 10:48

Hsieh

回復 12# b9208
標題列禁用合併儲存格，這是資料庫使用必須遵守的原則
你這樣會造成無法使用進階篩選

b9208

回復 14# Hsieh
謝謝HSIEH版主指導
修改報表標題設計格式，符合沒有合併格的格式。
感謝版主受益良多

b9208

回復 14# Hsieh
Dear Hsieh
小弟完成程式如附件
今再請教：
一、如何修正只有資料範圍填滿黃色。
二、相同資料列再比較k欄數量，保留一個最大值，其他數值改為0，格式為粗体紅字。
感謝指導

b211.rar (14.62 KB)

下載次數: 12

2013-3-11 21:52

Hsieh

回復 16# b9208

1. Sub ex()
   
2. Dim A As Range, C As Range, Rng As Range, MyRng As Range, m$
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Set d1 = CreateObject("Scripting.Dictionary")
   
5. With Sheets("單位")
   
6. Set Rng = .[D3:G3]
   
7.    With Sheets("資料")
   
8.       For Each A In .Range(.[F6], .[F6].End(xlDown))
   
9.       m = A.Offset(, -3) & A & A.Offset(, 2)
   
10.       If d(m) <= A.Offset(, 5).Value Then d(m) = A.Offset(, 5).Value '記住最大值
    
11.       d1(m) = d1(m) + 1 '計算個數
    
12.          Set C = Rng.Find(A, lookat:=xlWhole)
    
13.          If Not C Is Nothing Then
    
14.            If MyRng Is Nothing Then Set MyRng = A.Offset(, -5).Resize(, 13) Else Set MyRng = Union(MyRng, A.Offset(, -5).Resize(, 13))
    
15.          End If
    
16.       Next
    
17.     End With
    
18.     .Range("A19").CurrentRegion.Interior.ColorIndex = 0
    
19.     If Not MyRng Is Nothing Then MyRng.Copy .[A20] Else MsgBox "無符合資料": Exit Sub
    
20.     .Range("A19").CurrentRegion.Sort key1:=.[K19], Header:=xlYes
    
21.     .Range("A19").CurrentRegion.Sort key1:=.[F19], key2:=.[C19], key3:=.[H19], Header:=xlYes
    
22.     For Each A In .Range(.[F20], .[F20].End(xlDown))
    
23.     m = A.Offset(, -3) & A & A.Offset(, 2)
    
24.        If d1(m) > 1 Then A.Offset(, -5).Resize(, 13).Interior.ColorIndex = 6 '有重複
    
25.        If A.Offset(, 5) <> d(m) Then A.Offset(, 5) = 0 '不等於最大值就歸零
    
26.     Next
    
27. End With
    
28. End Sub

複製代碼

b9208

回復 17# Hsieh
謝謝Hsieh版本
執行ok
請教k欄最大值有二筆以上相同，可以保留第一筆數值，第二筆以後都為0。
目前執行後有相同最大值都保留。
謝謝指導

Hsieh

回復 18# b9208

最後一句
       If A.Offset(, 5) <> d(m) Then A.Offset(, 5) = 0 Else d(m) = 0 '不等於最大值就歸零

b9208

回復 19# Hsieh
Dear Hsieh
非常感謝您
執行後符合需要
多謝