VBA：如何从文件夹中的所有txt文件中读取和复制特定字符串

我在以下链接中找到了一个查找特定字符串的资源：

如何将此应用于文件夹中的所有.txt文件

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

---

我认为最好的方法是将所有文本文件中的所有数据导入到一张工作表中，然后筛选要查找的字符串，然后将它们复制/粘贴到另一张工作表中

请尝试下面的脚本从所有文件导入所有数据

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

---

使用Dir函数或FSO循环文件夹并添加一个.txt过滤器（文件掩码），您将继续覆盖A1，因此需要增加单元格引用。如果找不到，您还需要处理。将文件读取位放入自己的函数中。以供参考

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