Searching multiple occurence of same keyword from text file and saving its output in different Excel worksheets

Question

I am in need of a VBA script for doing mentioned task: 1.Searching multiple occurence of same keyword from the text file 2.Copy keyword line till end of the line of each occurence and paste in different worksheets for different occurences 3.Performs the "Text to Columns" operation using a semi-colon delimiter in all worksheets 4.Save the modified Excel file

Example:

Animals: Lion Tiger Zebra

Animals: Fast Aggressive No Horns

I want to search every occurence of word "Animals" in the text sheet, and paste each occurence till end of its line in different tabs of worksheet.

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

Answer 1

Please, try using the next adapted code:

Sub ProcessTextFile()
    Dim filePath As String, textLine As String, fileNum As Integer
    Dim wb As Workbook, ws As Worksheet
    Dim keyword As String, startRow As Long, wsCount As Integer
    Dim boolTab1 As Boolean 'to allow using the existing (unique) sheet...
    
    ' 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 = "Animals" 'appropriate for the received dummy text file...
    
    ' Create a new workbook
    Set wb = Workbooks.Add(xlWBATWorksheet) 'add a new workbook WITH A SINGLE SHEET
    wb.saveas FileName:="TELSTRA_AUDIT.xlsx"
    
    ' Open text file for reading
    fileNum = FreeFile
    Open filePath For Input As fileNum
    
    ' Initialize the counter
    wsCount = 1
    
    ' 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 OR USE EXISTING:
            If wb.Sheets.count = 1 And Not boolTab1 Then
                Set ws = wb.Worksheets(1): boolTab1 = True
            Else
                Set ws = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.count))
            End If
            ws.name = "Tab" & wsCount: wsCount = wsCount + 1
            startRow = 1 'initialize the variable to start inserting from the first row on each Tab sheet!
            ' 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
            startRow = startRow + 1
        Else
            ' place the row in an array (splitting by ;):
            arr = Split(textLine, ";")
            If UBound(arr) > 0 Then 'the line contains at least one ; separator:
                ws.cells(startRow, 1).Resize(, UBound(arr) + 1).value = arr 'drop the array content
                startRow = startRow + 1
            End If
        End If
    Loop
    
    ' Close the text file
    Close #fileNum
    
    ' Close the workbook
    wb.Close True
    
    MsgBox "Task completed successfully.", vbInformation
End Sub

The above code assumes that you need to (also) return all lines following the one where the keyword has been found, except the empty lines or others not containing any ";" separator.

Please, send some feedback after testing it