分割文件

Enocheasty

自荐一下，我的插件可以按你的要求输出表格
可以先通过数据-表格拆分拼接功能，将一张工作表按照固定的行数拆分为多个工作表，然后再通过工作表-拆分与合并，将每个表输出为单独的Excel文件。
https://club.excelhome.net/thread-1718774-1-1.html

wds1061

学习了，感谢分享。

yellowhawk

尝试ai生成：
Sub SplitWorkbookByRows()
    Dim wbOriginal As Workbook
    Dim wsOriginal As Worksheet
    Dim wbNew As Workbook
    Dim wsNew As Worksheet
    Dim LastRow As Long, i As Long, j As Long
    Dim StartRow As Long, EndRow As Long
    Dim TotalRows As Long
    Dim RowsPerFile As Long
    Dim NewFileName As String
    Dim FileCounter As Integer
    Dim fDialog As FileDialog
    Dim OriginalFilePath As String
    Dim OriginalFileName As String
    Dim FileExt As String
    Dim HeaderRange As Range
   
    ' ================== 配置区域 ==================
    RowsPerFile = 200 ' <--- 在这里修改你需要的行数
    ' ============================================
   
    ' 关闭屏幕刷新以提高速度
    Application.ScreenUpdating = False
   
    ' 1. 选择文件
    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
    With fDialog
        .Title = "请选择要分割的 Excel 文件"
        .Filters.Clear
        .Filters.Add "Excel 文件", "*.xlsx; *.xlsm"
        .AllowMultiSelect = False
        If .Show <> -1 Then
            MsgBox "未选择文件，操作已取消。"
            Exit Sub
        End If
        OriginalFilePath = .SelectedItems(1)
    End With
   
    ' 2. 打开源文件
    Set wbOriginal = Workbooks.Open(OriginalFilePath)
    Set wsOriginal = wbOriginal.Worksheets(1) ' 默认取第一个工作表
    LastRow = wsOriginal.Cells(wsOriginal.Rows.Count, "A").End(xlUp).Row
   
    ' 简单判断是否有数据（假设第一行是标题，数据从第二行开始）
    If LastRow < 2 Then
        MsgBox "数据不足，无需分割。"
        wbOriginal.Close False
        Exit Sub
    End If
   
    ' 获取原文件信息（用于命名新文件）
    OriginalFileName = Left(wbOriginal.Name, InStrRev(wbOriginal.Name, ".") - 1)
    FileExt = ".xlsx" ' 保存为标准格式
   
    ' 3. 循环分割
    FileCounter = 1
    ' 假设第一行是标题行，所以从第2行开始处理数据
    TotalRows = LastRow - 1
   
    ' 计算需要循环多少次
    Dim NumIterations As Long
    NumIterations = Int((TotalRows - 1) / RowsPerFile) + 1
   
    For i = 1 To NumIterations
        ' 计算起始行和结束行 (数据行号，不包含标题)
        StartRow = (i - 1) * RowsPerFile + 2 ' +2 是因为跳过标题行
        EndRow = Application.Min(StartRow + RowsPerFile - 1, LastRow)
        
        ' 创建新工作簿
        Set wbNew = Workbooks.Add
        Set wsNew = wbNew.Worksheets(1)
        
        ' 复制标题行 (第1行)
        wsOriginal.Rows(1).Copy Destination:=wsNew.Rows(1)
        
        ' 复制数据块
        wsOriginal.Rows(StartRow & ":" & EndRow).Copy Destination:=wsNew.Rows(2)
        
        ' 生成文件名：原名_编号.xlsx
        NewFileName = wbOriginal.Path & "\" & OriginalFileName & "_" & FileCounter & FileExt
        
        ' 保存并关闭新文件
        Application.DisplayAlerts = False ' 覆盖同名文件时不提示
        wbNew.SaveAs Filename:=NewFileName, FileFormat:=xlOpenXMLWorkbook
        wbNew.Close SaveChanges:=False
        Application.DisplayAlerts = True
        
        FileCounter = FileCounter + 1
    Next i
   
    ' 4. 完成
    Application.ScreenUpdating = True
    wbOriginal.Close False ' 关闭原文件不保存
    MsgBox "分割完成！共生成 " & (FileCounter - 1) & " 个文件。", vbInformation, "完成"
   
End Sub