【excel】按某列内容拆分表格,并单独保存为多个工作簿

ayaxiuying 评论311阅读模式

需要用到VBA,代码来自nototl在csdn网站上的原创文,需要详细步骤的请移步:【原文地址点这里】

以下是VBA代码:

Sub 保留表头拆分数据为若干新工作簿()

    Dim arr, d As Object, k, t, i&, lc%, rng As Range, c%

    c = Application.InputBox("请输入拆分列号", , 4, , , , , 1)

    If c = 0 Then Exit Sub

    Application.ScreenUpdating = False

    Application.DisplayAlerts = False

    arr = [a1].CurrentRegion

    lc = UBound(arr, 2)

    Set rng = [a1].Resize(, lc)

    Set d = CreateObject("scripting.dictionary")

    For i = 2 To UBound(arr)

        If Not d.Exists(arr(i, c)) Then

            Set d(arr(i, c)) = Cells(i, 1).Resize(1, lc)

        Else

            Set d(arr(i, c)) = Union(d(arr(i, c)), Cells(i, 1).Resize(1, lc))

        End If

    Next

    k = d.Keys

    t = d.Items

    For i = 0 To d.Count - 1

        With Workbooks.Add(xlWBATWorksheet)

            rng.Copy .Sheets(1).[a1]

            t(i).Copy .Sheets(1).[a2]

            .SaveAs Filename:=ThisWorkbook.Path & "\" & k(i) & ".xlsx"

            .Close

        End With

    Next

    Application.DisplayAlerts = True

    Application.ScreenUpdating = True

    MsgBox "完毕"

End Sub

匿名

发表评论

匿名网友

:?: :razz: :sad: :evil: :!: :smile: :oops: :grin: :eek: :shock: :???: :cool: :lol: :mad: :twisted: :roll: :wink: :idea: :arrow: :neutral: :cry: :mrgreen:

确定