Hsieh

回復 1# b9208

1. Sub ex()
   
2. Dim A As Range, Rng As Range
   
3. With Sheets("資料")
   
4.    For Each A In .Range(.[F6], .[F6].End(xlDown))
   
5.       If Application.CountIf(Sheets("單位").Rows(3), A) > 0 Then
   
6.          If Rng Is Nothing Then Set Rng = A Else Set Rng = Union(Rng, A)
   
7.       End If
   
8.    Next
   
9. End With
   
10. With Sheets("單位")
    
11. .[A19].CurrentRegion.Offset(1) = ""
    
12. If Not Rng Is Nothing Then Rng.EntireRow.Copy .[A20]
    
13. .[A19].CurrentRegion.Sort key1:=.[F20], key2:=.[E20], key3:=.[H20], Header:=xlYes
    
14. End With
    
15. End Sub

複製代碼

Hsieh

回復 10# b9208

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

Hsieh

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

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

複製代碼

Hsieh

回復 18# b9208

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