求VBA脚本：文本文件同关键词多匹配导出至Excel多工作表并处理

需求清单 #

• 在目标文本文件中搜索指定关键词的所有出现位置
• 每个关键词所在行及后续内容（直到下一个关键词出现前）单独存入Excel的一个新工作表
• 对所有工作表执行以分号为分隔符的**文本分列（Text to Columns）**操作
• 自动保存处理后的Excel文件

示例场景 #

待处理文本示例：

Animals:
Lion
Tiger
Zebra

Animals:
Fast
Aggressive
No Horns

预期效果：搜索到两处“Animals”，分别将对应段落内容存入Excel的两个独立工作表。

修正优化后的VBA代码 #

Sub ProcessTextFile()
    Dim filePath As String
    Dim textLine As String
    Dim fileNum As Integer
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim keyword As String
    Dim copyFlag As Boolean
    Dim startRow As Long
    Dim wsCount As Integer
    
    ' 让用户选择目标文本文件
    filePath = Application.GetOpenFilename("文本文件 (*.txt), *.txt")
    If filePath = "False" Then Exit Sub

    ' 设置要搜索的关键词（可取消注释改为弹窗输入）
    'keyword = InputBox("请输入要搜索的关键词:", "关键词搜索")
    'If keyword = "" Then Exit Sub
    keyword = "Animals" ' 替换为实际需要搜索的关键词
    
    ' 创建新工作簿并预保存
    Set wb = Workbooks.Add
    wb.SaveAs Filename:="处理结果.xlsx" ' 可修改保存路径和文件名
    
    ' 打开文本文件准备读取
    fileNum = FreeFile
    Open filePath For Input As fileNum
    
    ' 初始化变量
    copyFlag = False
    startRow = 1
    wsCount = 1
    
    ' 逐行读取文本文件
    Do While Not EOF(fileNum)
        Line Input #fileNum, textLine
        ' 检查当前行是否包含关键词
        If InStr(textLine, keyword) > 0 Then
            ' 若已在复制状态，先重置起始行（避免后续工作表起始行累加）
            If copyFlag Then
                startRow = 1
            End If
            ' 新建工作表
            Set ws = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
            ws.Name = "分表" & wsCount
            wsCount = wsCount + 1
            ' 将关键词所在行写入新工作表
            ws.Cells(startRow, 1).Value = textLine
            copyFlag = True
            startRow = startRow + 1
        ElseIf copyFlag Then
            ' 若处于复制状态，将当前行写入当前工作表
            ws.Cells(startRow, 1).Value = textLine
            startRow = startRow + 1
        End If
    Loop
    
    ' 关闭文本文件
    Close #fileNum
    
    ' 对所有工作表执行分号分隔的文本分列操作
    For Each ws In wb.Sheets
        ' 确保操作对象是当前工作表的单元格，避免跨表错误
        ws.UsedRange.TextToColumns Destination:=ws.Range("A1"), DataType:=xlDelimited, _
                                   TextQualifier:=xlDoubleQuote, Semicolon:=True
    Next ws
    
    ' 保存最终结果
    wb.Save
    
    ' 关闭工作簿（可根据需求注释此行，保留工作簿打开状态）
    wb.Close
    
    MsgBox "处理完成！", vbInformation
End Sub

代码说明 #

1. 文件选择：通过弹窗让用户选择要处理的文本文件，若取消选择则终止程序
2. 关键词设置：默认固定关键词，可取消注释改为弹窗输入自定义关键词
3. 分表逻辑：每找到一个关键词就新建工作表，将后续内容持续写入该表，直到下一个关键词出现
4. 文本分列：遍历所有工作表，对已使用区域执行分号分隔的文本分列
5. 自动保存：创建工作簿后立即预保存，处理完成后再次保存最终结果

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