導讀相信很多同學都遇到過如下使用工作情形：一張銷售訂單總表，需要按照銷售員拆分成多個單表，除了按照銷售員一個個篩選、復制到新文件，是否可以用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