VBA-拆分多个工作簿
通过手工键入行列数将总表拆分为多个工作簿
Sub 拆分成多个工作簿()'将报表按指定列分类并保存到各工作表中Dim i, c As Long, bj As String, rng As Range, arr(), myrows, lc As IntegerApplication.ScreenUpdating = FalseApplication.DisplayAlerts = Falsemyrows = Application.InputBox("请输入内容从第几行开始") '分类处理的第一条记录在第几行i = myrowsc = Application.InputBox("请输入拆分列号")arr = Range("A1").CurrentRegionlc = UBound(arr, 2)bj = Worksheets(1).Cells(i, c).ValueDo While bj <> "" '直到工作表中选中列的单元格为空单元格时终止循环On Error Resume Next '当没有对应工作表时，忽略下一行代码引起的运行错误If Worksheets(bj) Is Nothing Then '判断是否已有工作表，没有就新建并写入表头Worksheets.Add after:=Worksheets(Worksheets.Count)ActiveSheet.Name = bjWorksheets(1).Cells(1, "A").Resize(myrows - 1, lc).Copy Worksheets(bj).Cells(1, "A")End IfSet rng = Worksheets(bj).Range("A1048576").End(xlUp).Offset(1, 0) '确定工作表中A列的第一个空单元格，作为写入的目标区域Worksheets(1).Cells(i, "A").Resize(, lc).Copy rngi = i + 1bj = Worksheets(1).Cells(i, c).ValueLoop'MsgBox "已分类到各sheetta"Dim folder As Stringfolder = ThisWorkbook.Path & "\新建文件夹" '保存工作簿文件的目录If Len(Dir(folder, vbDirectory)) = 0 Then MkDir folder'选择是否新建该文件夹Dim sht As WorksheetFor Each sht In Worksheetssht.Copy '复制工作表到工作簿ActiveWorkbook.SaveAs folder & "\" & sht.Name & ".xlsx" '保存工作簿并命名ActiveWorkbook.CloseNextDim sht1 As WorksheetFor Each sht1 In WorksheetsIf sht1.Name <> Worksheets(1).Name Thensht1.DeleteEnd IfNextApplication.ScreenUpdating = TrueApplication.DisplayAlerts = TrueEnd Sub
