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

程技 VBA

发布时间 : 2023-10-23 00:00

字数:313 阅读 :

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

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

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

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

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

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

原始链接

转载请注明来源，欢迎对文章中的引用来源进行考证，欢迎指出任何有错误或不够清晰的表达。可以在下面评论区评论，也可以邮件至 richffan@outlook.com