VBA: How to read and copy specific string from all txt files in a folder

Question

I found a resource to find specific strings at the following link: https://www.excel-easy.com/vba/examples/read-data-from-text-file.html

How could I apply this to all the .txt files in a folder?

Sub READLINES()
Dim myFile As String, text As String, textline As String, posFood As Integer
'myFile = "C\FOLDER\TEST.txt"
myFile = Application.GetOpenFilename()

Open myFile For Input As #1

Do Until EOF(1)
    Line Input #1, textline
    text = text & textline
Loop
Close #1

posFood = InStr(text, "BACON")
Range("A1").Value = Mid(text, posFood + 7, 3) 'should return YUM

End Sub

Answer 1

I think your best bet is to import all data from all text files, into one single sheet, and then filter for the strings you want to find, and copy/paste those to another sheet.

Try the script below to import all data from all files.

Sub ImportCSVsWithReference()
'UpdatebyKutoolsforExcel20151214
    Dim xSht  As Worksheet
    Dim xWb As Workbook
    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String
    On Error GoTo ErrHandler
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a folder [Kutools for Excel]"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    Set xSht = ThisWorkbook.ActiveSheet
    If MsgBox("Clear the existing sheet before importing?", vbYesNo, "Kutools for Excel") = vbYes Then xSht.UsedRange.Clear
    Application.ScreenUpdating = False
    xFile = Dir(xStrPath & "\" & "*.txt")
    Do While xFile <> ""
        Set xWb = Workbooks.Open(xStrPath & "\" & xFile)
        Columns(1).Insert xlShiftToRight
        Columns(1).SpecialCells(xlBlanks).Value = ActiveSheet.Name
        ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
        xWb.Close False
        xFile = Dir
    Loop
    Application.ScreenUpdating = True
    Exit Sub
ErrHandler:
    MsgBox "no files csv", , "Kutools for Excel"
End Sub

Then, run this.

Sub MoveData()

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Dim Rng As Range

Set Rng = Range([A1], Range("A" & Rows.Count).End(xlUp))

On Error Resume Next
With Rng
.AutoFilter , field:=1, Criteria1:="Book1"
.SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets("Sheet2").Range("A1")
.AutoFilter
End With

Application.EnableEvents = True

End Sub