Hsieh

¦^´_ 3# marklos

1. Sub ex()
   
2. Dim ar()
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. With Sheets("Sheet1")
   
5. For Each a In .Range(.[A1], .[A1].End(xlDown))
   
6. x = Join(Application.Transpose(Application.Transpose(a.Resize(, 10).Value)), Chr(9))
   
7. If IsEmpty(d(x)) Then
   
8.   d(x) = x
   
9. y = Split(x, Chr(9))
   
10. If a.Offset(, 3) <> "" Then
    
11. For i = 1 To 2
    
12. If i = 2 Then y(0) = ""
    
13.   ReDim Preserve ar(s)
    
14.   ar(s) = y
    
15.   s = s + 1
    
16. Next
    
17. Else
    
18. ReDim Preserve ar(s): ar(s) = y: s = s + 1
    
19. End If
    
20. End If
    
21. Next
    
22. End With
    
23. With Sheets("Sheet3")
    
24. Application.DisplayAlerts = False
    
25. .[A1].Resize(s, 10) = Application.Transpose(Application.Transpose(ar))
    
26. Application.DisplayAlerts = True
    
27. End With
    
28. End Su

½Æ»s¥N½X