Excel宏需求：自动按Kod/Suma标记拆分工作表至新工作表

核心逻辑 #

• 自动遍历当前工作表，定位所有包含Kod:的单元格作为每组表格的起始行
• 从起始行向下查找第一个包含Suma:的单元格作为表格结束行
• 将起始到结束的完整区域复制到新建工作表，保留原单元格的行高、列宽及格式
• 全程无需手动选择范围，一键执行完成拆分

完整VBA代码 #

Sub AutoSplitTables()
    Dim wsSource As Worksheet
    Dim wsNew As Worksheet
    Dim startCell As Range
    Dim endCell As Range
    Dim startRow As Long, endRow As Long
    Dim tableNum As Integer
    
    ' 关闭屏幕更新，提升执行速度
    Application.ScreenUpdating = False
    ' 禁用事件触发，避免不必要干扰
    Application.EnableEvents = False
    
    Set wsSource = ActiveSheet
    tableNum = 1
    
    ' 查找第一个包含"Kod:"的单元格
    Set startCell = wsSource.Cells.Find(What:="Kod:", LookIn:=xlValues, LookAt:=xlPart)
    
    Do While Not startCell Is Nothing
        ' 从起始行向下查找第一个包含"Suma:"的单元格
        Set endCell = wsSource.Cells.Find(What:="Suma:", After:=startCell, LookIn:=xlValues, LookAt:=xlPart)
        
        If endCell Is Nothing Then
            MsgBox "找到起始标记但未匹配到对应的结束标记，拆分终止。", vbExclamation
            Exit Do
        End If
        
        startRow = startCell.Row
        endRow = endCell.Row
        
        ' 创建新工作表
        Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        wsNew.Name = "表格_" & tableNum
        
        ' 复制表格区域（默认列范围A-X，可根据实际修改最后一个参数的列号）
        wsSource.Range(wsSource.Cells(startRow, 1), wsSource.Cells(endRow, 24)).Copy
        
        ' 粘贴格式与内容，保留原单元格属性
        wsNew.Cells(1, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme
        wsNew.Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
        
        ' 同步行高，确保完全匹配原表格
        Dim i As Long
        For i = startRow To endRow
            wsNew.Rows(i - startRow + 1).RowHeight = wsSource.Rows(i).RowHeight
        Next i
        
        ' 定位下一个起始标记，避免重复处理
        Set startCell = wsSource.Cells.FindNext(After:=endCell)
        tableNum = tableNum + 1
    Loop
    
    ' 恢复系统默认设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    MsgBox "拆分完成，共生成 " & tableNum - 1 & " 个工作表。", vbInformation
End Sub

关键代码说明 #

• 标记自动定位：通过Find和FindNext方法遍历所有起始标记，无需手动指定范围
• 格式完整保留：用xlPasteAllUsingSourceTheme粘贴全部格式，xlPasteColumnWidths同步列宽，循环设置行高确保原单元格尺寸完全一致
• 执行效率优化：关闭屏幕更新和事件触发，减少卡顿与无效操作
• 异常处理：若起始标记无对应结束标记，会弹出提示并终止拆分，避免错误执行
• 自定义调整：代码中默认列范围为A到X（第24列），可根据实际表格宽度修改wsSource.Cells(endRow, 24)中的列号参数

使用步骤 #

1. 打开待拆分的Excel文件
2. 按Alt + F11打开VBA编辑器
3. 插入新模块，粘贴上述代码
4. 返回Excel界面，按Alt + F8选择AutoSplitTables宏执行即可

内容的提问来源于stack exchange，提问作者Adam Jar