Hsieh

¦^´_ 1# tsuan

1. Sub ¤ÀÃþ()
   
2. Dim A As Range, Ay()
   
3. Set Sht = CreateObject("Scripting.Dictionary")
   
4. Set dic = CreateObject("Scripting.Dictionary")
   
5. With Sheets("Á`ªí")
   
6. For Each A In .Range(.[A2], .[A2].End(xlDown))
   
7. For i = 5 To 9
   
8.    ar = Array(A.Offset(, 1), A.Offset(, 2), A.Offset(, 3), .Cells(A.Row, i).Value)
   
9.    If IsEmpty(dic(A & " " & .Cells(1, i))) Then
   
10.    ReDim Preserve Ay(1)
    
11.    Ay(0) = Array("³f¸¹", "³f«~´y­z", "³æ¦ì", "»ù®æ") '¼ÐÃD¦C
    
12.    Ay(1) = ar '¸ê®Æ¦C
    
13.       dic(A & " " & .Cells(1, i)) = Ay '¼È¦s©ó¦r¨åª«¥ó¤¤
    
14.       Else
    
15.       Ay = dic(A & " " & .Cells(1, i)) 'Ū¥X¦r¨å¤º®e
    
16.       s = UBound(Ay)
    
17.       ReDim Preserve Ay(s + 1)
    
18.       Ay(s + 1) = ar '¥[¤J¸ê®Æ¦C
    
19.       dic(A & " " & .Cells(1, i)) = Ay '¼È¦s©ó¦r¨åª«¥ó¤¤
    
20.     End If
    
21. Next
    
22. Next
    
23. End With
    
24. For Each sh In Sheets 'Ū¨ú©Ò¦³¤u§@ªí¦WºÙ
    
25.    Sht(sh.Name) = sh.Name
    
26. Next
    
27. For Each ky In dic.keys
    
28. If Not Sht.exists(ky) Then '­Y¤u§@ªí¤£¦s¦b
    
29. With Worksheets.Add(after:=Sheets(Sheets.Count)) '·s¼W¤u§@ªí
    
30.    .Name = ky
    
31. End With
    
32. End If
    
33. With Sheets(ky) '¼g¤J¤u§@ªí¸ê®Æ
    
34.    .[B1] = "À]§O:"
    
35.    .[D1] = "¼t°Ó:"
    
36.    .[C1] = Split(ky, " ")(0)
    
37.    .[E1] = Split(ky, " ")(1)
    
38.    .[A3].Resize(UBound(dic(ky)) + 1, 4) = Application.Transpose(Application.Transpose(dic(ky)))
    
39. End With
    
40. Next
    
41. End Sub

½Æ»s¥N½X