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

工作表按行拆分为工作表

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

工作表按行拆分为工作薄

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

举例

原始数据

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


拆分为工作薄

使用说明

本人为初学者（写的不好轻喷），根据大神的写法弄的精简版，中间出现空格可正常统计。

未进行序号填充

点击取消会报错

其他BUG后续将会继续完善

Sub 表格关键词拆分()
Application.ScreenUpdating = False
Dim x As Integer, y As Integer, w As Worksheet
inputcol = InputBox("请输入拆分列所在序号")
x = 2
y = inputcol
Set w = Worksheets(1)
Do While w.Cells(x, y).Value <> ""
    On Error Resume Next
    If Worksheets(w.Cells(x, y).Value) Is Nothing Then
        Worksheets.Add after:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = w.Cells(x, y).Value
        w.Cells(1, 1).Resize(1, 100).Copy Worksheets(w.Cells(x, y).Value).Cells(1, 1)
    End If
    w.Cells(x, 1).Resize(1, 100).Copy Worksheets(w.Cells(x, y).Value).Range("A60000").End(xlUp).Offset(1, 0)
x = x + 1
Loop

Dim folder As String
folder = ThisWorkbook.Path & "拆分工作表"
If Len(Dir(folder, vbDirectory)) = 0 Then MkDir folder
Dim i As Integer, sht As Worksheet
For i = 2 To Sheets.Count
    Sheets(i).Copy
    ActiveWorkbook.SaveAs folder & "\" & Sheets(1).Name & ".xls"
    ActiveWorkbook.Close
Next
End Sub

 如图，这边需要按照工作内容拆分多个工作表，直接上代码：

Sub splitSht()
Dim sht As Worksheet
Dim d As Object
Dim j As Integer

    Set sht = ThisWorkbook.Worksheets("Sheet1")
    Set d = CreateObject("scripting.dictionary")
    With sht
        rrow = .Range("A65535").End(xlUp).Row
        For i = 2 To rrow
            strr = .Range("E" & i).Value
            If Not d.exists(strr) Then
                d.Add strr, .Range("A1").Resize(1, 7)
                Set d.Item(strr) = Union(d.Item(strr), .Range("A" & i).Resize(1, 7))
            Else
                Set d.Item(strr) = Union(d.Item(strr), .Range("A" & i).Resize(1, 7))
            End If
        Next
        k = d.keys
        i = d.items
        For j = 0 To d.Count - 1
            ThisWorkbook.Worksheets.Add after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
            ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count).Name = k(j)
            i(j).Copy Worksheets(k(j)).Range("A1")
            Worksheets(k(j)).Cells.EntireColumn.AutoFit
        Next
    End With
End Sub

因为字典具有唯一key 的属性， 通过字典记录所有key 和用union获取所有值，开始的d.Add strr....是用于记录表的标题，然后通过 value.copy把值输出到每个信标中。