Hsieh

¦^´_ 34# iceandy6150
´ê­Ó¼ö¾x

1. Sub CreateTable()
   
2. Dim i%, Ar(), Rng As Range, A As Range, sht As Object, ky As Variant, k&, s&
   
3. Set sht = CreateObject("Scripting.Dictionary")
   
4. Application.DisplayAlerts = False
   
5. With Sheets("Sheet1")
   
6. i = .Index + 1
   
7. Do Until Sheets.Count < i '§R°£Sheet1¤§«áªº¤u§@ªí
   
8.    Sheets(i).Delete
   
9.    i = .Index + 1
   
10. Loop
    
11. For Each A In .Range(.[G2], .[G2].End(xlDown)) '¤ÀÃþÀx¦s
    
12.   Set Rng = Sheets("°Ñ·Óªí").[A:A].Find(A, lookat:=xlWhole) '§ä¨ì°Ñ·Ó
    
13.   If IsEmpty(sht(Rng.Offset(, 1).Value)) Then '¤ÀÃþ²Ä¤@­Ó
    
14.   ReDim Preserve Ar(0)
    
15.      Ar(0) = Array(A.Offset(, -3).Value, "", "", "", A.Offset(, -1).Value, "", A.Offset(, -2).Value)
    
16.      sht(Rng.Offset(, 1).Value) = Ar
    
17.      Else '¤ÀÃþÄ~Äò§ä¨ì
    
18.      Ar = sht(Rng.Offset(, 1).Value)
    
19.      s = UBound(Ar)
    
20.      ReDim Preserve Ar(s + 1)
    
21.      Ar(s + 1) = Array(A.Offset(, -3).Value, "", "", "", A.Offset(, -1).Value, "", A.Offset(, -2).Value)
    
22.      sht(Rng.Offset(, 1).Value) = Ar
    
23.      Erase Ar
    
24.    End If
    
25. Next
    
26. For Each ky In sht.keys '¥Î¤ÀÃþ·í¦¨¯Á¤Þ­È
    
27. Ar = sht(ky)
    
28. s = UBound(Ar) + 1
    
29. With Sheets.Add(after:=Sheets(Sheets.Count)) '·s¼W¤u§@ªí
    
30. .Name = ky '¥H¤ÀÃþ¬°ªí¦WºÙ
    
31.   Set Rng = Sheets("ªí®æ½d¥»").[A1:K22] 'ªí®æ½d¥»½d³ò
    
32.   Rng.Copy .[A1]: k = 0: .Cells(k + 2, 3) = ky
    
33.   For i = 0 To UBound(Ar) '¼g¤J¸ê®Æ
    
34.      .Cells(i + 7 + Int(i / 13) * 13, 4).Resize(, 7) = Application.Index(Ar, i)
    
35.     If (i + 1) Mod 13 = 0 Then k = k + 26: Rng.Copy .[A1].Offset(k, 0): .Cells(k + 2, 3) = ky '13µ§¬°¤@­Óªí®æ
    
36.   Next
    
37. End With
    
38. Next
    
39. 'Âà¦ÜÁ`ªí
    
40. If MsgBox("¬O§_¦s¤JÁ`ªí", vbYesNo) = 6 Then .Range("A1").CurrentRegion.Offset(1).Copy Sheets("Á`ªí").Cells(.Rows.Count, 1).End(xlUp).Offset(3)
    
41. MsgBox "¤ÀÃþ§¹¦¨"
    
42. End With
    
43. End Sub

½Æ»s¥N½X