把excel中的数据，按条件分割成多个文件

要求

VBA代码

Sub 拆分成多个文件()

'输入用户想要拆分的工作表
Dim sheet_name
sheet_name = Application.InputBox("请输入拆分工作表的名称：")
Worksheets(sheet_name).Select

'输入获取拆分需要的条件列
Dim col_name
col_name = Application.InputBox("请输入拆分依据的列号(如A):")

'输入拆分的开始行，要求输入的是数字
Dim start_row As Integer
start_row = Application.InputBox(prompt:="请输入拆分的开始行:", Type:=1)

'暂停屏幕更新
Application.ScreenUpdating = False

'工作表的总行数
Dim end_row
end_row = Worksheets(sheet_name).Range("A65536").End(xlUp).Row

'遍历计算所有拆分表，每个拆分表的格式为"表名称,表行数"
'对于二维数组，ReDim只能扩充最后一维，因此sheet_map行不变，扩充列
Dim sheet_map(), sheet_index
ReDim sheet_map(1, 0)
sheet_map(0, 0) = Range(col_name & start_row).Value
sheet_map(1, 0) = 1
sheet_index = 0

With Worksheets(sheet_name)
Dim row_count, temp, i
row_count = 0
For i = start_row + 1 To end_row
temp = Range(col_name & i).Value
If temp = Range(col_name & (i - 1)).Value Then
sheet_map(1, sheet_index) = sheet_map(1, sheet_index) + 1
Else
ReDim Preserve sheet_map(1, sheet_index + 1)
sheet_index = sheet_index + 1
sheet_map(0, sheet_index) = temp
sheet_map(1, sheet_index) = 1
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) & ".xls"
ActiveWorkbook.SaveAs Filename:=workbook_path, FileFormat:=-4143
ActiveSheet.Name = sheet_map(0, i)
'激活当前工作簿，ThisWorkbook表示当前跑代码的工作簿
ThisWorkbook.Activate

'拷贝条目数据(即最前面不需要拆分的数据行)
Dim row_range
row_range = 1 & ":" & (start_row - 1)
Worksheets(sheet_name).Rows(row_range).Copy
Workbooks(sheet_map(0, i) & ".xls").Sheets(1).Range("A1").PasteSpecial
'拷贝拆分表的专属数据
row_range = row_index & ":" & (row_index + sheet_map(1, i) - 1)
Worksheets(sheet_name).Rows(row_range).Copy
Workbooks(sheet_map(0, i) & ".xls").Sheets(1).Range("A" & start_row).PasteSpecial
row_index = row_index + sheet_map(1, i)

'保存文件
Workbooks(sheet_map(0, i) & ".xls").Close SaveChanges:=True
Next

'进行屏幕更新
Application.ScreenUpdating = True

MsgBox "拆分工作表完成"

End Sub

遇到的小问题

宏被禁用