Sub split_sheet()     '输入用户想要拆分的工作表     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("A990000").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     Dim name_hz As String     name_hz = "-20161220-M.xlsx"     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) & name_hz         ActiveWorkbook.SaveAs workbook_path         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) & name_hz).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) & name_hz).Sheets(1).Range("A" & start_row).PasteSpecial         row_index = row_index + sheet_map(1, i)         '保存文件         Workbooks(sheet_map(0, i) & name_hz).Close SaveChanges:=True     Next     '进行屏幕更新     Application.ScreenUpdating = True     MsgBox "拆分工作表完成"   End Sub

将一个工作簿分割成多个工作簿并保存到相同文件夹中

Sub Splitbook()'Updateby20140612Dim xPath As StringxPath = Application.ActiveWorkbook.PathApplication.ScreenUpdating = FalseApplication.DisplayAlerts = FalseFor Each xWs In ThisWorkbook.Sheets    xWs.Copy    Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xls"    Application.ActiveWorkbook.Close FalseNextApplication.DisplayAlerts = TrueApplication.ScreenUpdating = TrueEnd Sub