VBA代码，Sub 按输入的表头拆分成多表！

Sub 按输入的表头拆分成多表()
Dim r As Long, c As Long, i As Long, m As Long, h As Long, hp As Long
Dim arr As Variant
Dim rng As Range
Dim ws As Worksheet
Dim sheetname As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False

h = Application.InputBox(prompt:="请输入表头行数，最大为10", Title:="操作提示", Default:=1, Type:=1)

If h = 0 Or h > 10 Then
Exit Sub
End If

m = Application.InputBox(prompt:="请输入每个表格的行数，最大为50万行", Title:="操作提示", Default:=100, Type:=1)

If m = 0 Or m > 500000 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(h + 1, 1), .Cells(r, c))
arr = rng.Value
End With

sheetname = ActiveSheet.Name

hp = 1

For i = h To r Step m
Set ws = Worksheets.Add(After:=Worksheets(Worksheets.Count))
ActiveSheet.Name = hp

With ws
.Range("A1").Resize(h, c).Value = rng.Offset(-h, 0).Resize(h, c).Value

If i + m - 1 <= r Then
.Range("A" & h + 1).Resize(m, c).Value = rng.Offset(i - 1, 0).Resize(m, c).Value
Else
Dim remainingRows As Long
remainingRows = r - i + 1
.Range("A" & h + 1).Resize(remainingRows, c).Value = rng.Offset(i - 1, 0).Resize(remainingRows, c).Value
.Range("A" & h + remainingRows + 1).Resize(m - remainingRows, c).ClearContents
End If
End With

hp = hp + 1
Next

Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "拆分完成！"
End Sub

学习资料见知识星球。

以上就是今天要分享的技巧，你学会了吗？若有什么问题，欢迎在下方留言。

快来试试吧，小琥 my21ke007。获取 1000个免费 Excel模板福利​​​​！

更多技巧， www.excelbook.cn

欢迎 加入 零售创新 知识星球，知识星球主要以数据分析、报告分享、数据工具讨论为主；