工作表按行拆分为工作表

Sub 按输入的行数拆分成多表()
Dim r%, c%, i%, m%
Dim arr, brr
Dim rng As Range
Dim ws As Worksheet
Dim sheetname As String

t = Timer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each sht In Worksheets
If sht.Name <> Sheet1.Name Then sht.Delete
Next
m = Application.InputBox(prompt:="请输入每个表格的行数,最大10万行", Title:="操作提示", Default:=100, Type:=1)

If m = 0 Or m > 100000 Then
Exit Sub
End If
With ActiveSheet
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set rng = .Range(.Cells(1, 1), .Cells(1, c))
End With
sheetname = ActiveWindow.ActiveSheet.Name


hp = 1
For i = 2 To r Step m
Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
ActiveSheet.Name = hp
With ws
rng.Copy .Range("a1")
Worksheets(sheetname).Cells(i, 1).Resize(m, c).Copy .Range("a2")
End With
hp = hp + 1
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "拆分时间：" & Format(Timer - t, "0.000") & "秒"
End Sub

• 工作表按行拆分为工作薄

Sub 工作表按行拆分为工作薄()
'当前工作表（worksheet）按固定行数拆分保存为多个工作簿（workbook），文件单独保存
tm = Now()

n = Application.InputBox(prompt:="请输入每个表格的行数", Title:="操作提示", Default:=100, Type:=1)

Application.Visible = False '后台运行，不显示界面
Application.ScreenUpdating = False
Application.DisplayAlerts = False '不显示警告信息
Set fso = CreateObject("Scripting.FileSystemObject")
'--------------------参数填写：num_row，数字；title_row表头行数，数字，第1行为1向下递增
title_row = 1 '表头行数，每个拆分后的sheet都保留
num_row = n '拆分数据行数，按多少行数据进行拆分，不能完全拆分的，多余行数单独
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.ScreenUpdating = True
Application.DisplayAlerts = True
Debug.Print ("工作表已拆分完成，累计用时" & Format(Now() - tm, "hh:mm:ss")) '耗时

End Sub

举例

原始数据

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


拆分为工作薄