Hsieh

¦^´_ 3# alltest
Book1ªº¤@¯ë¼Ò²Õ

1. Sub Split_Data()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. With ThisWorkbook
   
4.    With .Sheets(1)
   
5.       For Each a In .Range(.[A1], .[A1].End(xlDown))
   
6.          If IsEmpty(d(a & "")) Then
   
7.             Set d(a & "") = a.Resize(, 4)
   
8.          Else
   
9.             Set d(a & "") = Union(d(a & ""), a.Resize(, 4))
   
10.          End If
    
11.       Next
    
12.       For Each ky In d.keys
    
13.          Set sh = Worksheets.Add(after:=Sheets(Sheets.Count))
    
14.          d(ky).Copy sh.[A1]
    
15.          sh.Name = ky
    
16.       Next
    
17.     End With
    
18.    .Sheets(d.keys).Move
    
19. End With
    
20.      
    
21. End Sub

½Æ»s¥N½X

Hsieh

¦^´_ 6# alltest
¸Õ¸Õ¬Ý
book2ªº¤@¯ë¼Ò²Õ

1. Sub Auto_Open()
   
2. Dim ary(), fs$, Sh As Worksheet
   
3. Dim ay(1), Ar, Ky, s&
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. fs = ThisWorkbook.Path & "\book1.xls"
   
6. With Workbooks.Open(fs)
   
7.    With .Sheets(1)
   
8.       For Each A In .Range(.[B3], .[B3].End(xlDown))
   
9.       r = A.Row
   
10.          For Each b In .Range(.[E1], .[IV1].End(xlToLeft).Offset(, -1)).SpecialCells(xlCellTypeConstants)
    
11.          k = b.Column
    
12.          Ar = Array(.Cells(r, 2).Value, .Cells(r, 3).Value, .Cells(r, 4).Value, .Cells(r, k).Value, .Cells(r, k + 1).Value, .Cells(r, k + 2).Value)
    
13.          If IsEmpty(d(A & "-" & b)) Then
    
14.             ay(0) = Ar
    
15.             d(A & "-" & b) = ay
    
16.             Else
    
17.             ary = d(A & "-" & b)
    
18.             s = UBound(ary)
    
19.             ReDim Preserve ary(s + 1)
    
20.             ary(s) = Ar
    
21.             d(A & "-" & b) = ary
    
22.          End If
    
23.          Next
    
24.         Next
    
25.      End With
    
26. For Each Sh In ThisWorkbook.Sheets
    
27.     With Sh
    
28.        .UsedRange.Offset(2) = ""
    
29.        Ky = .Name
    
30.        If IsArray(d(Ky)) Then
    
31.        ary = d(Ky)
    
32.        For i = 0 To UBound(ary) - 1
    
33.          .Cells(3 + i, 1).Resize(, UBound(Ar) + 1) = ary(i)
    
34.        Next
    
35.        End If
    
36.     End With
    
37. Next
    
38.      .Close 0
    
39. End With
    
40. End Sub

½Æ»s¥N½X