我需要一个 VBA 脚本来完成上述任务： 1.从文本文件中搜索多次出现的相同关键字 2.将关键字行复制到每个出现的行尾，然后针对不同的出现粘贴到不同的工作表中 3.在所有工作表中使用分号分隔符执行“文本分列”操作 4.保存修改后的Excel文件
示例：
动物： 狮子 老虎 斑马
动物： 快速地 挑衅的 没有喇叭
我想在文本表中搜索单词“Animals”的每个出现，并将每个出现粘贴到工作表的不同选项卡中直到其行尾。
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 keywordFound As Boolean
Dim copyFlag As Boolean
Dim startRow As Long
Dim wsCount As Integer
' Ask user for the path of the text file
filePath = Application.GetOpenFilename("Text Files (*.txt), *.txt")
If filePath = "False" Then Exit Sub
' Prompt user for keyword to search for
'keyword = InputBox("Enter the keyword to search for:", "Keyword Search")
'If keyword = "" Then Exit Sub
keyword = "MO "
' Create a new workbook
Set wb = Workbooks.Add
wb.SaveAs Filename:="TELSTRA_AUDIT.xlsx"
' Open text file for reading
fileNum = FreeFile
Open filePath For Input As fileNum
' Initialize flags and counters
keywordFound = False
copyFlag = False
startRow = 1
wsCount = 1
' Read file line by line
Do While Not EOF(fileNum)
Line Input #fileNum, textLine
' Check if the line contains the keyword
If InStr(textLine, keyword) > 0 Then
' If keyword found, create a new worksheet
Set ws = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
ws.Name = "Tab" & wsCount
wsCount = wsCount + 1
' Copy the line and text below keyword till end of the line to the new worksheet
ws.Cells(startRow, 1).Value = textLine
copyFlag = True
' Move to the next row
startRow = startRow + 1
keywordFound = True
ElseIf copyFlag Then
' Copy lines below keyword till end of the line to the current worksheet
ws.Cells(startRow, 1).Value = textLine
' Move to the next row
startRow = startRow + 1
End If
Loop
' Close the text file
Close #fileNum
' Perform Text to Columns operation using semi-colon delimiter in all worksheets
For Each ws In wb.Sheets
ws.UsedRange.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, Semicolon:=True
Next ws
' Save the modified Excel file
wb.Save
' Close the workbook
wb.Close
MsgBox "Task completed successfully.", vbInformation
End Sub
您没有回答我的澄清问题，所以我假设您需要将每个出现的地方粘贴到新添加的工作表中（如您的代码所做的那样），但在其第一行中...
如果我的假设是正确的，请替换这部分代码：
' Read file line by line
Do While Not EOF(fileNum)
Line Input #fileNum, textLine
' Check if the line contains the keyword
If InStr(textLine, keyword) > 0 Then
' If keyword found, create a new worksheet
Set ws = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
ws.Name = "Tab" & wsCount
wsCount = wsCount + 1
' Copy the line and text below keyword till end of the line to the new worksheet
ws.Cells(startRow, 1).Value = textLine
copyFlag = True
' Move to the next row
startRow = startRow + 1
keywordFound = True
ElseIf copyFlag Then
' Copy lines below keyword till end of the line to the current worksheet
ws.Cells(startRow, 1).Value = textLine
' Move to the next row
startRow = startRow + 1
End If
Loop
' Close the text file
Close #fileNum
' Perform Text to Columns operation using semi-colon delimiter in all worksheets
For Each ws In wb.Sheets
ws.UsedRange.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, Semicolon:=True
Next ws
' Save the modified Excel file
wb.Save
' Close the workbook
wb.Close
与下一个改编版本。它将分割线（通过“;”）放置在必要的 xls 文件行中。它在每个新添加的工作表的第一行中执行此操作。如果您需要其他东西，可以轻松地调整代码来完成它。不再需要 TextToColumns：
' Read file line by line
Dim arr 'new variable to place the line in an array
Do While Not EOF(fileNum)
Line Input #fileNum, textLine
' Check if the line contains the keyword
If InStr(textLine, keyword) > 0 Then
' If keyword found, create a new worksheet
Set ws = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.count))
ws.name = "Tab" & wsCount
wsCount = wsCount + 1
' place the row in an array (splitting by ;):
arr = Split(textLine, ";")
ws.cells(startRow, 1).Resize(, UBound(arr) + 1).value = arr 'drop the array content
End If
Loop
' Close the text file
Close #fileNum
' Close the workbook
wb.Close True 'close and and saving in the same code line