工作表的冻结与拆分（拆分工作表小工具）

导读相信很多同学都遇到过如下使用工作情形：一张销售订单总表，需要按照销售员拆分成多个单表，除了按照销售员一个个筛选、复制到新文件，是否可以用vba来做呢？该怎么....

相信很多同学都遇到过如下使用工作情形：一张销售订单总表，需要按照销售员拆分成多个单表，除了按照销售员一个个筛选、复制到新文件，是否可以用vba来做呢？该怎么做呢？案例案例名称

待拆分工作表.xlsx：

按照姓名拆分成“张三.xlsx”、“李四.xlsx”和“王二.xlsx”。

你只需要打开附件中的“按照第一列拆分表格.xlsm”，点击拆分按钮即可。

这个vba程序我已经包装好，按照说明使用就可以了，如果需要学习代码，代码也未加密，可以直接查看。

小工具获取方法：

一、将本文分享到朋友圈，并截图；

二、将截图私信发送给本号，我将会回复给您百度网盘下载的地址和提取码。

关键代码：

Sub main_module()

Application.ScreenUpdating = True

打开待拆分表格

Dim bookA As Workbook

Dim sheetA As Worksheet

Dim rowcountA As Long

Dim resDicA As Object

Set resDicA = CreateObject("Scripting.Dictionary")

Call public_module.getObjs(ThisWorkbook.path & "待拆分表格.xlsx", "Sheet1", resDicA)

Set bookA = resDicA.Item("book")

Set sheetA = resDicA.Item("sheet")

rowcountA = resDicA.Item("sheetRowsCount")

新建文件对象

Set fso = CreateObject("scripting.filesystemobject")

循环第一列

Dim filename1, filename As String

Dim i

For i = 2 To rowcountA

filename1 = sheetA.Cells(i, 1)

If Trim(filename1) <> "" Then

filename = filename1

Else

filename = "筛选值为空"

End If

filenamelong = filename & ".xlsx"

If fso.FileExists(ThisWorkbook.path & "" & filenamelong) = True Then

MsgBox "文件存在"

Else

MsgBox filename & "文件不存在"

Set newbk = Workbooks.Add

sheetA.[a1].AutoFilter 1, filename1

sheetA.[a1].CurrentRegion.SpecialCells(xlCellTypeVisible).Copy newbk.Sheets(1).[a1]

dirname = ThisWorkbook.path & "" & filenamelong

ActiveWorkbook.SaveAs dirname

Workbooks(filenamelong).Close True

Application.ScreenUpdating = True

End If

Next i

bookA.Close Savechanges:=True

End Sub