Excel·VBA按行拆分工作表

对应之前文章《Excel·VBA按列拆分工作表、工作簿》，对Excel表格数据按照固定行数，将工作表拆分

代码使用建议：建议使用 方法3，其他2个版本的代码写法较为原始，仅供代码学习参考

1，工作表按行拆分为工作表

Sub 工作表按行拆分为工作表()
    '当前工作表（worksheet）按固定行数拆分为多个工作表，保存在当前工作簿（workbook）
    tm = Now()
    Set ws = Application.ActiveSheet  '当前工作表即为待拆分工作表
'--------------------参数填写：num_row，数字；title_row表头行数，数字，第1行为1向下递增
    title_row = 1  '表头行数，每个拆分后的sheet都保留
    num_row = 100  '拆分数据行数，按多少行数据进行拆分，不能完全拆分的，多余行数单独
    max_row = ActiveSheet.UsedRange.Rows.count
    '拆分sheet数量，向上取整
    sheet_count = WorksheetFunction.RoundUp((max_row - title_row) / num_row, 0)
    
    For i = 1 To sheet_count:
        Worksheets.Add(after:=Sheets(Sheets.count)).Name = "拆分表" & i  '最后添加新sheet，并命名
        With ActiveSheet
            ws.Rows(1 & ":" & title_row).Copy  '本行复制表头，下行复制数据
			.Range("A1").PasteSpecial Paste:=xlPasteAll
			.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
            ws.Rows(num_row * (i - 1) + title_row + 1 & ":" & (num_row * i) + title_row).Copy .Range("A" & title_row + 1)
        End With
        'Exit For  '强制退出for循环，单次测试使用
    Next
	Debug.Print ("拆分完成，累计用时" & Format(Now() - tm, "hh:mm:ss"))  '耗时
End Sub

2，工作表按行拆分为工作薄

Sub 工作表按行拆分为工作薄()
    '当前工作表（worksheet）按固定行数拆分保存为多个工作簿（workbook），文件单独保存
    tm = Now()
    Application.Visible = False  '后台运行，不显示界面
    Application.DisplayAlerts = False  '不显示警告信息
    Set fso = CreateObject("Scripting.FileSystemObject")
'--------------------参数填写：num_row，数字；title_row表头行数，数字，第1行为1向下递增
	title_row = 1  '表头行数，每个拆分后的sheet都保留
    num_row = 100  '拆分数据行数，按多少行数据进行拆分，不能完全拆分的，多余行数单独
    Set ws = Application.ActiveSheet  '当前工作表即为待拆分工作表
    wb_path = Application.ActiveWorkbook.Path  '当前工作簿文件路径
    wb_name = Application.ActiveWorkbook.Name  '当前工作簿文件名和扩展名
    save_path = wb_path + "\拆分表"  '保存拆分后的表格保存路径
    max_row = ActiveSheet.UsedRange.Rows.count
    '拆分sheet数量，向上取整
    sheet_count = WorksheetFunction.RoundUp((max_row - title_row) / num_row, 0)
    If fso.FolderExists(save_path) Then
        Debug.Print ("拆分文件保存路径已存在：" & save_path)
    Else
        fso.CreateFolder (save_path)
        Debug.Print ("拆分文件保存路径已创建：" & save_path)
    End If
    
    For i = 1 To sheet_count:
        Workbooks.Add
        With ActiveSheet
            ws.Rows(1 & ":" & title_row).Copy  '本行复制表头，下行复制数据
			.Range("A1").PasteSpecial Paste:=xlPasteAll
			.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
            ws.Rows(num_row * (i - 1) + title_row + 1 & ":" & (num_row * i) + title_row).Copy .Range("A" & title_row + 1)
        End With
        '保存文件全名（文件路径、文件名、扩展名）
        save_file = save_path & "\" & fso.GetBaseName(wb_name) & "_拆分表" & i & "." & fso.GetExtensionName(wb_name)
        ActiveWorkbook.SaveAs filename:=save_file
        ActiveWorkbook.Close (False)
        'Exit For  '强制退出for循环，单次测试使用
    Next
    Set fso = Nothing  '释放内存
    Application.Visible = True
    Application.DisplayAlerts = True
    Debug.Print ("工作表已拆分完成，累计用时" & Format(Now() - tm, "hh:mm:ss"))  '耗时
End Sub

1、2举例

原始数据

参数：表头行数title_row = 1、按每5行拆分num_row = 5
拆分为工作表


拆分为工作薄

3，工作表按行拆分

将拆分为工作表和工作簿的代码合并在一起

Sub 工作表按行拆分_复制法()
    '当前工作表ws按固定行数拆分为多个ws或工作簿wb，文件保存在当前wb同一文件夹下单独文件夹内
    Dim fso As Object, title_row&, num_row&, save_type$, max_row&, max_col&
    Dim title_rng As Range, rng As Range, save_path$, file_name$, ws_name$, i&, j&
'--------------------参数填写：title_row数字；num_row数字；save_type字符串
    title_row = 1   '表头行数，每个拆分后的sheet都保留
    num_row = 100   '固定拆分行数
    save_type = "ws"   '保存方式：ws拆分为工作表，wb拆分为工作簿
    Set fso = CreateObject("Scripting.FileSystemObject"): tm = Timer
    Application.ScreenUpdating = False  '关闭屏幕更新，加快程序运行
    Application.DisplayAlerts = False   '不显示警告信息
    With ActiveSheet
        max_row = .UsedRange.Rows.Count: max_col = .UsedRange.Columns.Count
        Set title_rng = .[a1].Resize(title_row, max_col)
        If save_type = "ws" Then    '拆分为工作表
            For i = title_row + 1 To max_row Step num_row
                Set rng = .Cells(i, 1).Resize(num_row, max_col): j = j + 1 '最后添加新sheet，并命名
                .Parent.Worksheets.Add(after:=Sheets(Sheets.Count)).Name = "拆分表" & j
                With ActiveSheet
                    title_rng.Copy  '复制表头及列宽，复制数据
                    .[a1].PasteSpecial Paste:=xlPasteAll
                    .[a1].PasteSpecial Paste:=xlPasteColumnWidths
                    rng.Copy .Cells(title_row + 1, 1)
                End With
            Next
        ElseIf save_type = "wb" Then    '拆分为工作簿
            save_path = .Parent.path + "\拆分表\"  '保存拆分后的表格保存路径
            file_name = fso.GetBaseName(.Parent.Name) + "_拆分表"  '文件名
            ws_name = .Name: Dim write_wb As Workbook
            If Not fso.FolderExists(save_path) Then fso.CreateFolder (save_path)  '创建文件夹
            For i = title_row + 1 To max_row Step num_row
                Set rng = .Cells(i, 1).Resize(num_row, max_col): j = j + 1 '最后添加新sheet，并命名
                Set write_wb = Workbooks.Add  '新建工作簿，拆分文件
                With ActiveSheet
                    title_rng.Copy  '复制表头及列宽，复制数据
                    .[a1].PasteSpecial Paste:=xlPasteAll
                    .[a1].PasteSpecial Paste:=xlPasteColumnWidths
                    rng.Copy .Cells(title_row + 1, 1)
                    .Name = ws_name  '工作表命名
                End With
                '保存文件全名（文件路径、文件名、扩展名）
                write_wb.SaveAs filename:=save_path & file_name & j & ".xlsx"
                write_wb.Close (False)
            Next
        End If
    End With
    Application.ScreenUpdating = True: Application.DisplayAlerts = True
    Debug.Print "工作表已拆分完成，累计用时" & Format(Timer - tm, "0.00")  '耗时
End Sub