VB多个sheet按某一条件拆分成单个表格拆分后的单个文件包含多个sheet

多个sheet按某一条件拆分成单个表格（拆分后
的单个文件包含多个sheet）
注:标颜色的是需要根据实际数据更改部分
Private Sub CommandButton1_Click（）
Dim t As Single
t = Timer
'通过专员（四季度）表获取所有大区信息
Worksheets（"专员（四季度）"）.Select
’输入获取拆分需要的条件列
Dim col_name
col_name = "D"
’输入拆分的开始行，要求输入的是数字
Dim start_row As Integer
start_row = 5
'暂停屏幕更新
Application.ScreenUpdating = False
’工作表的总行数
Dim end_row
end_row = Worksheets("专员(四季度)").Range("A65536").End(xlUp).Row
'将大区信息保存入数组
'对于二维数组，ReDim只能扩充最后一维，因此sheet_m叩行不变，扩充列Dim sheet_map(), sheet_index
ReDim sheet_map(1, 0)
sheet_map(0, 0) = Worksheets。

'专员(四季度)").Range(col_name &
start_row).Value
sheet_map(1, 0) = 1
sheet_index = 0
With Worksheets("专员(四季度)。

Dim have, temp, i
For i = start_row + 1 To end_row
temp = Worksheets("专员(四季度)").Range(col_name & i).Value have = 0
For j = 0 To sheet_index
If temp = sheet_map(0, j) Then
have = 1
End If
If have = 0 Then
ReDim Preserve sheet_map(1, sheet_index + 1)
sheet_index = sheet_index + 1
sheet_map(0, sheet_index) = temp
End If
Next
End With
’根据前面计算的拆分表，拆分成单个文件
Dim row_index
row_index = start_row
For i = 0 To sheet_index
Workbooks.Add
’创建最终数据文件夹
Dim dir_name
dir_name = ThisWorkbook.Path & "\按大区拆分出的表格\"
If Dir(dir_name, vbDirectory) = "" Then
MkDir (dir_name)
End If
'创建新工作簿
Dim workbook_path
workbook_path = ThisWorkbook.Path & "\按大区拆分出的表格\" & sheet_map(0, i) & ".xlsx"
ActiveWorkbook.SaveAs workbook_path
For k = Workbooks(sheet_map(0, i) & ".xlsx").Sheets.Count To 3 Step -1 Workbooks(sheet_map(0, i) & ".xlsx").Sheets(k).Delete
Next
'最后一个sheet前加单引号防止创建空表此句可删掉
Sheets.Add after:=Workbooks(sheet_map(0, i) & ".xlsx").Sheets(1)
Sheets.Add after:=Workbooks(sheet_map(0, i) & ".xlsx").Sheets(2)
Sheets.Add after:二Workbooks(sheet_map(0, i) & ".xlsx").Sheets(3)
Sheets.Add after:二Workbooks(sheet_map(0, i) & ".xlsx").Sheets(4)
Sheets.Add after:=Workbooks(sheet_map(0, i) & ".xlsx").Sheets(5)
' Sheets.Add after:=Workbooks(sheet_map(0, i) & ".xlsx").Sheets(6)
Workbooks(sheet_map(0, i) & ".xlsx").Sheets(1).Name ="专员(四季度)
Workbooks(sheet_map(0, i) & ".xlsx").Sheets(2).Name ="经理(四季度)
Workbooks(sheet_map(0, i) & ".xlsx").Sheets(3).Name = 2绩效得分-专员"
Workbooks(sheet_map(0, i) & ".xlsx").Sheets(4).Name = 2绩效得分-经理"
Workbooks(sheet_map(0, i) & ".xlsx").Sheets(5).Name ="超期罚款"
Workbooks(sheet_map(0, i) & ".xlsx").Sheets(6).Name ="退货罚款"
第一个sheet页拆分
'激活当前工作簿，ThisWorkbook表示当前跑代码的工作簿
ThisWorkbook.Activate
end_row = Worksheets("专员(四季度)").Range("A65536").End(xlUp).Row
号拷贝条目数据(即最前面不需要拆分的数据行)
Dim row_range
row_range = 1 & ":" & (5 - 1)
Worksheets。

'专员(四季度)").Rows(row_range).Copy
Workbooks(sheet_map(0, i) & ".xlsx").Sheets(1).Range("A1").PasteSpecial
拷贝拆分表的专属数据
Dim pasterow
pasterow = 5
For j = 5 To end_row
If Worksheets("专员(四季度)").Range("D" & j).Value = sheet_map(0, i) Then
Worksheets("专员(四季度)").Rows(j).Copy
Workbooks(sheet_map(0, i) & ".xlsx").Sheets(1).Range("A" & pasterow).PasteSpecial
pasterow = pasterow + 1
End If
第二个sheet页拆分
'激活当前工作簿，ThisWorkbook表示当前跑代码的工作簿
ThisWorkbook.Activate
end_row = Worksheets("经理(四季度)").Range("A65536").End(xlUp).Row
号拷贝条目数据(即最前面不需要拆分的数据行)
row_range = 1 & ":" & (5 - 1)
Worksheets("经理(四季度)").Rows(row_range).Copy
Workbooks(sheet_map(0, i) & ".xlsx").Sheets(2).Range("A1").PasteSpecial
拷贝拆分表的专属数据
pasterow = 5
For j = 5 To end_row
If Worksheets("经理(四季度)").Range("D" & j).Value = sheet_map(0, i)
Then
Worksheets("经理(四季度)").Rows(j).Copy
Workbooks(sheet_map(0, i) & ".xlsx").Sheets(2).Range("A" & pasterow).PasteSpecial
pasterow = pasterow + 1
End If
第三个sheet页拆分 '激活当前工作簿，ThisWorkbook表示当前跑代码的工作簿
ThisWorkbook.Activate
end_row = Worksheets("绩效得分-专员").Range("A65536").End(xlUp).Row
号拷贝条目数据(即最前面不需要拆分的数据行)
row_range = 1 & ":" & (3 - 1)
Worksheets。

'绩效得分-专员").Rows(row_range).Copy
Workbooks(sheet_map(0, i) & ".xlsx").Sheets(3).Range("A1").PasteSpecial
拷贝拆分表的专属数据
pasterow = 3
For j = 3 To end_row
If Worksheets("绩效得分-专员").Range("C" & j).Value = sheet_map(0, i) Then
Worksheets("绩效得分-专员").Rows(j).Copy
Workbooks(sheet_map(0, i) & ".xlsx").Sheets(3).Range("A" & pasterow).PasteSpecial
pasterow = pasterow + 1
End If
'激活当前工作簿，ThisWorkbook表示当前跑代码的工作簿
ThisWorkbook.Activate
end_row = Worksheets("绩效得分-经理").Range("A65536").End(xlUp).Row
号拷贝条目数据(即最前面不需要拆分的数据行)
row_range = 1 & ":" & (3 - 1)
Worksheets。

'绩效得分-经理").Rows(row_range).Copy
Workbooks(sheet_map(0, i) & ".xlsx").Sheets(4).Range("A1").PasteSpecial
拷贝拆分表的专属数据
pasterow = 3
For j = 3 To end_row
If Worksheets("绩效得分-经理").Range("C" & j).Value = sheet_map(0, i) Then
Worksheets("绩效得分-经理").Rows(j).Copy
Workbooks(sheet_map(0, i) & ".xlsx").Sheets(4).Range("A" & pasterow).PasteSpecial
pasterow = pasterow + 1
End If
'激活当前工作簿，ThisWorkbook表示当前跑代码的工作簿
ThisWorkbook.Activate
end_row = Worksheets("超期罚款").Range("A65536").End(xlUp).Row
号拷贝条目数据(即最前面不需要拆分的数据行)
row_range = 1 & ":" & (2 - 1)
Worksheets。

'超期罚款").Rows(row_range).Copy
Workbooks(sheet_map(0, i) & ".xlsx").Sheets(5).Range("A1").PasteSpecial
拷贝拆分表的专属数据
pasterow = 2
For j = 2 To end_row
If Worksheets("超期罚款").Range("E" & j).Value = sheet_map(0, i) Then Worksheets("超期罚款").Rows(j).Copy
Workbooks(sheet_map(0, i) & ".xlsx").Sheets(5).Range("A" & pasterow).PasteSpecial
pasterow = pasterow + 1
'激活当前工作簿，ThisWorkbook表示当前跑代码的工作簿
ThisWorkbook.Activate
end_row = Worksheets("退货罚款").Range("A65536").End(xlUp).Row
号拷贝条目数据(即最前面不需要拆分的数据行)
row_range = 1 & ":" & (2 - 1)
Worksheets。

'退货罚款").Rows(row_range).Copy
Workbooks(sheet_map(0, i) & ".xlsx").Sheets(6).Range("A1").PasteSpecial
拷贝拆分表的专属数据
pasterow = 2
For j = 2 To end_row
If Worksheets("退货罚款").Range("W" & j).Value = sheet_map(0, i) Then Worksheets("退货罚款").Rows(j).Copy
Workbooks(sheet_map(0, i) & ".xlsx").Sheets(6).Range("A" & pasterow).PasteSpecial
pasterow = pasterow + 1
'保存文件
Workbooks(sheet_map(0, i) & ".xlsx").Close SaveChanges:=True Next
’进行屏幕更新
Application.ScreenUpdating = True
MsgBox ("按大区拆分工作表完成！用时"& Timer - t & "秒")
End Sub。