excelvbacopy-paste

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


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

Solution

  • 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