Hsieh

1. Sub nn()
   
2. Set d = CreateObject("Scripting.dictionary")
   
3. Set d1 = CreateObject("Scripting.dictionary")
   
4. Dim Ar()
   
5. Range("A4").CurrentRegion.Sort key1:=[A5], Header:=xlYes
   
6. A = [A4].CurrentRegion.Offset(1)
   
7. For i = 1 To UBound(A)
   
8. If IsEmpty(d(A(i, 1) & A(i, 5))) Then
   
9.     d(A(i, 1) & A(i, 5)) = Array(Application.Index(A, i))
   
10.     d1(A(i, 1) & A(i, 5)) = d1(A(i, 1) & A(i, 5)) + 1
    
11.     Else
    
12.     Ar = d(A(i, 1) & A(i, 5))
    
13.     ReDim Preserve Ar(d1(A(i, 1) & A(i, 5)))
    
14.     Ar(d1(A(i, 1) & A(i, 5))) = Array(Application.Index(A, i))
    
15.     d(A(i, 1) & A(i, 5)) = Ar
    
16.     d1(A(i, 1) & A(i, 5)) = d1(A(i, 1) & A(i, 5)) + 1
    
17.   End If
    
18. Next
    
19. r = 5
    
20. [A4].CurrentRegion.Offset(1) = ""
    
21. For Each ky In d.keys
    
22. If ky <> "" Then
    
23.    Cells(r, 1).Resize(UBound(d(ky)) + 1, 7) = Application.Transpose(Application.Transpose(d(ky)))
    
24.    Cells(r + UBound(d(ky)) + 1, 5) = "Sub Total:"
    
25.    Cells(r + UBound(d(ky)) + 1, 6) = Application.Sum(Application.Index(d(ky), , 6))
    
26.    r = r + UBound(d(ky)) + 3
    
27. End If
    
28. Next
    
29. End Su

½Æ»s¥N½X