Excel拆分脚本

工作表按行拆分为工作薄

打开要拆分的Excel文件，使用==快捷键（Alt+F11）==打开脚本界面，选择要拆分的sheet，打开Module，在Module中输入脚本代码，然后运行脚本

Sub 工作表按行拆分为工作薄()Dim tm As DateDim fso As ObjectDim ws As WorksheetDim wb As WorkbookDim newWb As WorkbookDim savePath As StringDim wbPath As StringDim wbName As StringDim saveFile As StringDim titleRow As LongDim numRows As LongDim maxRow As LongDim sheetCount As LongDim i As LongDim lastRowCopied As Long' 初始化tm = NowApplication.Visible = FalseApplication.DisplayAlerts = FalseSet fso = CreateObject("Scripting.FileSystemObject")' 参数设置titleRow = 1numRows = 50000Set ws = ThisWorkbook.ActiveSheetwbPath = ThisWorkbook.PathwbName = ThisWorkbook.NamesavePath = wbPath & "\split"' 创建保存路径文件夹（如果不存在）If Not fso.FolderExists(savePath) Thenfso.CreateFolder savePathEnd If' 计算最大行数和拆分后的工作表数量maxRow = ws.UsedRange.Rows.CountsheetCount = WorksheetFunction.RoundUp((maxRow - titleRow) / numRows, 0)' 循环拆分并保存工作簿On Error GoTo ErrorHandlerFor i = 1 To sheetCount' 创建新工作簿Set newWb = Workbooks.AddWith newWb.Sheets(1)' 复制表头ws.Rows("1:" & titleRow).Copy Destination:=.Rows("1:" & titleRow)' 复制数据lastRowCopied = numRows * (i - 1) + titleRow + numRowsIf lastRowCopied > maxRow Then lastRowCopied = maxRowws.Rows(numRows * (i - 1) + titleRow + 1 & ":" & lastRowCopied).Copy Destination:=.Rows(titleRow + 1)' 复制列宽（可选）.Columns("A:Z").AutoFit ' 或者指定需要的列End With' 保存新工作簿saveFile = savePath & "\" & fso.GetBaseName(wbName) & "_split" & i & "." & fso.GetExtensionName(wbName)newWb.SaveAs Filename:=saveFilenewWb.Close FalseSet newWb = Nothing ' 释放新工作簿对象Next i' 清理和恢复设置Set fso = NothingApplication.Visible = TrueApplication.DisplayAlerts = TrueDebug.Print "工作表已拆分完成，累计用时" & Format(Now() - tm, "hh:mm:ss")Exit SubErrorHandler:MsgBox "错误 " & Err.Number & ": " & Err.Description, vbCritical' 清理和恢复设置（错误处理中的清理）If Not newWb Is Nothing Then newWb.Close FalseSet fso = NothingApplication.Visible = TrueApplication.DisplayAlerts = True
End Sub