保留表头将excel工作表拆分成若干工作簿

日常工作中经常会遇到将一个excel工作表的明细拆分为若干个工作簿明细分发到不同的人，例如工资条附件，如果一个个复制粘贴处理太麻烦了，使用如下宏语句，可以迅速将这个工能实现，亲试，

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) & ".xls"

            .Close

        End With

    Next

    Application.DisplayAlerts = True

    Application.ScreenUpdating = True

    MsgBox "完毕"

End Sub