GBKEE

¦^´_ 4# yuch8663

1. Sub Ex()
   
2. Dim D As Object, D1 As Object, Sh As Worksheet, Ar(), A As Range, B As Range
   
3. Set D = CreateObject("Scripting.Dictionary")
   
4. Set D1 = CreateObject("Scripting.Dictionary")
   
5. ReDim Preserve Ar(2)
   
6. Ar(0) = Sheets("Sheet1").[A1]
   
7. Ar(1) = Sheets("Sheet1").[B1]
   
8. For Each Sh In Sheets(Array("Sheet1", "Sheet2", "Sheet3", "Sheet4"))
   
9. With Sh
   
10. For Each A In .Range(.[C1], .[IV1].End(xlToLeft))
    
11. If Not IsNumeric(Application.Match(A, Ar, 0)) Then
    
12. Ar(UBound(Ar)) = A.Value
    
13. ReDim Preserve Ar(UBound(Ar) + 1)
    
14. End If
    
15. For Each B In .Range(A.Offset(1, 0), .Cells(65536, A.Column).End(xlUp))
    
16. D1(.Cells(B.Row, 1) & .Cells(B.Row, 2)) = Array(.Cells(B.Row, 1), .Cells(B.Row, 2))
    
17. D(.Cells(B.Row, 1) & .Cells(B.Row, 2) & A) = D(.Cells(B.Row, 1) & .Cells(B.Row, 2) & A) + B.Value
    
18. Next
    
19. Next
    
20. End With
    
21. Next
    
22. With Sheet5
    
23. .Cells = ""
    
24. .[A1].Resize(, UBound(Ar)) = Ar
    
25. .[A2].Resize(D1.Count, 2) = Application.Transpose(Application.Transpose(D1.ITEMS))
    
26. For Each C In .Range(.[C1], .[IV1].End(xlToLeft))
    
27. For Each A In C.Offset(1, 0).Resize(D1.Count, 1)
    
28. A = D(.Cells(A.Row, 1) & .Cells(A.Row, 2) & C)
    
29. Next
    
30. Next
    
31. End With
    
32. End Sub

½Æ»s¥N½X