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

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

8
    ar = Range("a1:e" & [a65536].End(3).Row)
9
    Dim irow
10
    For i = 2 To UBound(ar)
11
        kw = ar(i, 4)
12
        If Not d.exists(kw) Then
13
            ReDim tmp(1 To 5000, 1 To UBound(ar, 2) + 1)
14
            For j = 1 To UBound(ar, 2)
15
                tmp(1, j) = ar(1, j)
16
                tmp(2, j) = ar(i, j)
17
            Next
18
            tmp(1, UBound(ar, 2) + 1) = 2
19
            d(kw) = tmp
20
        Else
21
            tmp = d(kw)
22
            irow = tmp(1, UBound(ar, 2) + 1) + 1
23
            For j = 1 To UBound(ar, 2)
24
                tmp(irow, j) = ar(i, j)
25
            Next
26
            tmp(1, UBound(ar, 2) + 1) = irow
27
            d(kw) = tmp
28
        End If
29
    Next i
30

31
    Dim dk
32
    For Each dk In d.keys
33
        With ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
34
            .Name = dk
35
            tmp = d(dk)
36
            .[a1].Resize(tmp(1, UBound(ar, 2) + 1), UBound(ar, 2)) = tmp
37
        End With
38
    Next
39

40
End Sub