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

大家好！如何按照表中的某一列，拆分成独立的Sheet? 如下：

这是一个特别常见常用的问题，本期分享本人用的最多的两个方法中的第一个。

因为确实不太容易理解，所以分为两部分。

这个方法非常的实用，在其他地方也可以发挥很大的作用，所以墙裂推荐大家掌握！

以下是VBA代码。详细解析请看文末的视频。

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

原始链接