Hsieh

¦^´_ 1# pitera88
VBA»²§U¤ñ¸û²³æ

1. Private Sub CommandButton1_Click()
   
2. Dim Sh As Worksheet
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. For Each Sh In Sheets(Array("A", "B"))
   
5.    With Sh
   
6.       For Each a In .Range(.[B2], .[B2].End(xlDown))
   
7.          d(a.Value) = a.Offset(, -1).Resize(, 4).Value
   
8.       Next
   
9.     End With
   
10. Next
    
11. With Sheets(3)
    
12. .UsedRange.Offset(1).ClearContents
    
13. .[A2].Resize(d.Count, 4).Value = Application.Transpose(Application.Transpose(d.items))
    
14. .[A2].Resize(d.Count, 4).Sort key1:=.Cells(1, 1), Header:=xlNo
    
15. End With
    
16. End Sub

½Æ»s¥N½X

¾ã²z.rar (12.03 KB)

¤U¸ü¦¸¼Æ: 6

2012-3-23 21:21

Hsieh

¦^´_ 4# pitera88

B¤u§@ªí¦³¸ê®Æ´N¼g¤JB¤u§@ªí¡A¨S¦³ªº´N¥HA¤u§@ªí¬°·Ç

1. Private Sub CommandButton1_Click()
   
2. Dim Sh As Worksheet, A As Range
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. For Each Sh In Sheets(Array("A", "B"))
   
5.    With Sh
   
6.       For Each A In .Range(.[B2], .[B2].End(xlDown))
   
7.          If IsEmpty(d(A.Value)) Then
   
8.             d(A.Value) = Application.Transpose(Application.Transpose(A.Offset(, -1).Resize(, 7).Value))
   
9.             Else
   
10.             ar = d(A.Value)
    
11.             For i = LBound(ar) To UBound(ar)
    
12.               If A.Offset(, -1).Resize(, 7).Cells(1, i) <> "" Then ar(i) = A.Offset(, -1).Resize(, 7).Cells(1, i).Value
    
13.               d(A.Value) = ar
    
14.             Next
    
15.             End If
    
16.       Next
    
17.     End With
    
18. Next
    
19. With Sheets(3)
    
20. .UsedRange.Offset(1).ClearContents
    
21. .[A2].Resize(d.Count, 7).Value = Application.Transpose(Application.Transpose(d.items))
    
22. .[A2].Resize(d.Count, 7).Sort key1:=.Cells(1, 1), Header:=xlNo
    
23. End With
    
24. End Sub

½Æ»s¥N½X