用VBA拆分表格，保留表头

Sub SplitDataIntoFiles()
    Dim sourceSheet As Worksheet
    Dim totalRows As Long, totalDataRows As Long, chunks As Long, i As Long
    Dim startDataRow As Long, endDataRow As Long
    Dim newWorkbook As Workbook
    Dim savePath As String
    Dim copyRange As Range
    Dim dataRange As Range
    
    ' 错误处理
    On Error GoTo ErrorHandler
    
    ' 设置数据源工作表
    Set sourceSheet = ThisWorkbook.ActiveSheet
    
    ' 计算总行数（包含表头）
    totalRows = sourceSheet.UsedRange.Rows.Count
    If totalRows = 0 Then
        MsgBox "未检测到数据！请检查工作表内容。", vbExclamation
        Exit Sub
    End If
    
    ' 计算有效数据行数（排除表头）
    totalDataRows = totalRows - 1
    If totalDataRows < 1 Then
        MsgBox "没有数据行可供拆分！", vbExclamation
        Exit Sub
    End If
    
    ' 计算分块数量（每块4800条数据）
    chunks = Application.WorksheetFunction.RoundUp(totalDataRows / 4800, 0)
    
    ' 处理保存路径
    savePath = ThisWorkbook.Path & "\SplitFiles\"
    If Dir(savePath, vbDirectory) = "" Then MkDir savePath
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    For i = 1 To chunks
        ' 计算当前块的数据起始和结束行
        startDataRow = 2 + (i - 1) * 4800    ' 数据从第2行开始
        endDataRow = startDataRow + 4800 - 1  ' 计算理论结束行
        If endDataRow > totalRows Then endDataRow = totalRows ' 限制不超过总行数
        
        ' 检查起始行有效性
        If startDataRow > totalRows Then Exit For
        
        ' 设置数据范围
        Set dataRange = sourceSheet.Rows(startDataRow & ":" & endDataRow)
        
        ' 合并表头与数据范围
        Set copyRange = Union(sourceSheet.Rows(1), dataRange)
        
        ' 复制并创建新工作簿
        copyRange.Copy
        Set newWorkbook = Workbooks.Add
        With newWorkbook.Sheets(1)
            .Paste Destination:=.Range("A1")
            .Columns.AutoFit
        End With
        
        ' 保存文件
        newWorkbook.SaveAs _
            Filename:=savePath & "Split_" & Format(i, "000") & ".xlsx", _
            FileFormat:=xlOpenXMLWorkbook
        newWorkbook.Close SaveChanges:=False
        
        ' 释放对象
        Set copyRange = Nothing
        Set dataRange = Nothing
    Next i
    
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "成功拆分 " & chunks & " 个文件！保存路径：" & vbCrLf & savePath, vbInformation
    Exit Sub

ErrorHandler:
    MsgBox "错误 " & Err.Number & ": " & Err.Description & vbCrLf & _
           "发生位置：i=" & i & ", 行范围 " & startDataRow & "-" & endDataRow, vbCritical
    Application.ScreenUpdating = True
End Sub