一张工作表拆分为多个工作簿

一张工作表拆分为多个工作簿

工作场景：

一张工作表存储所有销售人员的业绩明细，需要按照销售人员拆分为多个工作簿，一个销售人员一个工作簿。

如果销售人员不多就3-5个，先筛选，再复制粘贴也不算费时间，如果几十个甚至更多，用这种方法就太慢了，分享VBA方法。

点击开发工具Visual Basic或者快捷键【Alt+F11】进入VBE编辑界面，输入以下代码，运行代码，提示按照第几列拆分，比如，销售人员所在的字段是第14列，输入14，就按照销售人员拆分为多个文件，拆分的文件名为销售人员的名字。

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

更多工作表和工作簿拆分文章如下，点击文字可以查看。

作者聂美骐，原名聂春霞，2001年-2005年在江西移动工作，2005年开始就职于腾讯公司，2011年开始兼职腾讯学院Excel课程讲师，2015年4月出版图书《Excel高手捷径：一招鲜，吃遍天》，同年12月在中国台湾出版繁体字版。2017年5月出版第二版《Excel职场手册：260招菜鸟变达人》。