如何使用VBA将单个工作表数据按指定关键词拆分至多个工作表

适用场景 #

• 仅在指定的A1:K10000单元格范围搜索指定关键词
• 每次匹配到关键词后，自动将其下方对应内容复制到新建工作表
• 循环处理所有匹配结果，自动完成全量拆分

前置注意 #

运行代码前请先备份原始数据表，避免操作失误导致数据丢失

• 代码默认匹配完全一致的关键词，如果需要模糊匹配，可修改代码中LookAt参数
• 代码默认复制关键词下方的内容，若需要包含关键词行，可调整复制区域的起始行参数
• 新工作表默认命名为「关键词_匹配行号」，自动规避重名报错

完整VBA代码 #

Sub 按关键词拆分工作表()
    ' 定义变量
    Dim 源表 As Worksheet
    Dim 搜索范围 As Range
    Dim 匹配单元格 As Range
    Dim 第一个匹配地址 As String
    Dim 下一个匹配 As Range
    Dim 结束行 As Long
    Dim 新表 As Worksheet
    Dim 搜索关键词 As String
    
    ' ===== 配置项：可根据实际需求修改 =====
    Set 源表 = ActiveSheet ' 如需指定固定工作表，可改为 Set 源表 = ThisWorkbook.Worksheets("你的源表名")
    搜索关键词 = "替换为你要搜索的关键词" ' 填写实际要匹配的内容
    ' ==================================
    
    ' 设置搜索范围为A1:K10000
    Set 搜索范围 = 源表.Range("A1:K10000")
    
    ' 查找第一个匹配项
    Set 匹配单元格 = 搜索范围.Find(What:=搜索关键词, LookIn:=xlValues, LookAt:=xlWhole) ' LookAt改为xlPart即为模糊匹配
    
    ' 未找到关键词则退出
    If 匹配单元格 Is Nothing Then
        MsgBox "未找到指定关键词，程序退出"
        Exit Sub
    End If
    
    ' 记录第一个匹配项的地址，用于循环终止判断
    第一个匹配地址 = 匹配单元格.Address
    
    ' 循环处理所有匹配项
    Do
        ' 新建工作表
        Set 新表 = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        ' 新工作表命名，自动规避重名错误
        On Error Resume Next
        新表.Name = 搜索关键词 & "_" & 匹配单元格.Row
        On Error GoTo 0
        
        ' 确定当前匹配项对应内容的结束行
        Set 下一个匹配 = 搜索范围.FindNext(After:=匹配单元格)
        If 下一个匹配 Is Nothing Or 下一个匹配.Address = 第一个匹配地址 Then
            ' 最后一个匹配项，结束行取数据最后一行，最多不超过10000行
            结束行 = Application.Min(10000, 源表.UsedRange.Rows.Count)
        Else
            ' 非最后一个匹配项，结束行为下一个匹配项的上一行
            结束行 = 下一个匹配.Row - 1
        End If
        
        ' 复制内容到新表：默认复制关键词下方内容，如需包含关键词行，将+1去掉即可
        源表.Range("A" & 匹配单元格.Row + 1 & ":K" & 结束行).Copy 新表.Range("A1")
        
        ' 查找下一个匹配项
        Set 匹配单元格 = 搜索范围.FindNext(After:=匹配单元格)
    Loop While Not 匹配单元格 Is Nothing And 匹配单元格.Address <> 第一个匹配地址
    
    MsgBox "拆分完成！"
End Sub

运行步骤 #

• 打开需要拆分的Excel文件，按Alt+F11调出VBA编辑器
• 在左侧工程面板右键点击当前工作簿，选择「插入」-「模块」
• 将上述代码粘贴到弹出的模块编辑窗口中，修改配置项部分的关键词、源表参数
• 按F5运行代码即可完成拆分

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