【VBA案例014】拆分工作表（上）

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40

Sub 数组装进字典()
    Dim i, j, k
    Dim ar, tmp()
    Dim d As Object, kw$
    Set d = CreateObject("Scripting.Dictionary")
    'd.CompareMode = vbTextCompare '不区分大小写

    ar = Range("a1:e" & [a65536].End(3).Row)
    Dim irow
    For i = 2 To UBound(ar)
        kw = ar(i, 4)
        If Not d.exists(kw) Then
            ReDim tmp(1 To 5000, 1 To UBound(ar, 2) + 1)
            For j = 1 To UBound(ar, 2)
                tmp(1, j) = ar(1, j)
                tmp(2, j) = ar(i, j)
            Next
            tmp(1, UBound(ar, 2) + 1) = 2
            d(kw) = tmp
        Else
            tmp = d(kw)
            irow = tmp(1, UBound(ar, 2) + 1) + 1
            For j = 1 To UBound(ar, 2)
                tmp(irow, j) = ar(i, j)
            Next
            tmp(1, UBound(ar, 2) + 1) = irow
            d(kw) = tmp
        End If
    Next i

    Dim dk
    For Each dk In d.keys
        With ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
            .Name = dk
            tmp = d(dk)
            .[a1].Resize(tmp(1, UBound(ar, 2) + 1), UBound(ar, 2)) = tmp
        End With
    Next

End Sub