Excel拆分脚本

工作表按行拆分为工作薄

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

Sub 工作表按行拆分为工作薄()
    Dim tm As Date
    Dim fso As Object
    Dim ws As Worksheet
    Dim wb As Workbook
    Dim newWb As Workbook
    Dim savePath As String
    Dim wbPath As String
    Dim wbName As String
    Dim saveFile As String
    Dim titleRow As Long
    Dim numRows As Long
    Dim maxRow As Long
    Dim sheetCount As Long
    Dim i As Long
    Dim lastRowCopied As Long
    
    ' 初始化
    tm = Now
    Application.Visible = False
    Application.DisplayAlerts = False
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' 参数设置
    titleRow = 1
    numRows = 50000
    Set ws = ThisWorkbook.ActiveSheet
    wbPath = ThisWorkbook.Path
    wbName = ThisWorkbook.Name
    savePath = wbPath & "\split"
    
    ' 创建保存路径文件夹（如果不存在）
    If Not fso.FolderExists(savePath) Then
        fso.CreateFolder savePath
    End If
    
    ' 计算最大行数和拆分后的工作表数量
    maxRow = ws.UsedRange.Rows.Count
    sheetCount = WorksheetFunction.RoundUp((maxRow - titleRow) / numRows, 0)
    
    ' 循环拆分并保存工作簿
    On Error GoTo ErrorHandler
    For i = 1 To sheetCount
        ' 创建新工作簿
        Set newWb = Workbooks.Add
        With newWb.Sheets(1)
            ' 复制表头
            ws.Rows("1:" & titleRow).Copy Destination:=.Rows("1:" & titleRow)
            ' 复制数据
            lastRowCopied = numRows * (i - 1) + titleRow + numRows
            If lastRowCopied > maxRow Then lastRowCopied = maxRow
            ws.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:=saveFile
        newWb.Close False
        Set newWb = Nothing ' 释放新工作簿对象
    Next i
    
    ' 清理和恢复设置
    Set fso = Nothing
    Application.Visible = True
    Application.DisplayAlerts = True
    Debug.Print "工作表已拆分完成，累计用时" & Format(Now() - tm, "hh:mm:ss")
    Exit Sub
    
ErrorHandler:
    MsgBox "错误 " & Err.Number & ": " & Err.Description, vbCritical
    ' 清理和恢复设置（错误处理中的清理）
    If Not newWb Is Nothing Then newWb.Close False
    Set fso = Nothing
    Application.Visible = True
    Application.DisplayAlerts = True
End Sub