遍历文件和子文件夹，并查找文本

Question

我正在做某事，但我卡住了。 我想在我的文件夹和文件夹的子文件夹中查找所有 xl 文件，并查找一个字符串，例如“bbb”并打印找到该字符串的所有文件和单元格。

例如，我有一个名为“bla”的文件夹，其中包含三个 xl 文件，还有另一个文件夹“bla2”，还有 4 个 xl 文件。它在所有文件中查找“bbb”，并打印一个包含文件路径和匹配单元格的新工作表。

所以，几乎一切正常，只是它在我的一个循环中运行了很多次，所以它打印了重复的值。

代码如下：

Sub SearchFolders()
Dim fso As Object
Dim strSearch As String
Dim strFile As String
Dim wOut As Worksheet
Dim wbk As Workbook
Dim wks As Worksheet
Dim lRow As Long
Dim rFound As Range
Dim strFirstAddress As String
Dim oFolder, oSubfolder, oFile, queue As Collection
Dim HostFolder As String

HostFolder = "C:\Users\a\Desktop\xl files"

On Error GoTo ErrHandler
Application.ScreenUpdating = False

strSearch = "bbb" 'the text to match

Set wOut = Worksheets.Add
lRow = 1
With wOut
    .Cells(lRow, 1) = "Workbook"
    .Cells(lRow, 2) = "Worksheet"
    .Cells(lRow, 3) = "Cell"
    .Cells(lRow, 4) = "Text in Cell"

    'now some iterations through subfolders and folders
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set queue = New Collection
    queue.Add fso.GetFolder(HostFolder)

    Do While queue.Count > 0
        Set oFolder = queue(1)
        queue.Remove 1 'dequeue

        For Each oSubfolder In oFolder.SubFolders
            queue.Add oSubfolder 'enqueue
        Next oSubfolder
        For Each oFile In oFolder.Files
            strFile = Dir(oFolder & "\*.xls*")
            '**********************************************************************
            Do While strFile <> "" '***THIS IS THE LOOP WHERE I THINK THE PROBLAM IS
                Set wbk = Workbooks.Open _
                  (Filename:=oFolder & "\" & strFile, _
                  UpdateLinks:=0, _
                  ReadOnly:=True, _
                  AddToMRU:=False)

                For Each wks In wbk.Worksheets
                    Set rFound = wks.UsedRange.Find(strSearch, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
                    If Not rFound Is Nothing Then
                        strFirstAddress = rFound.Address
                    End If
                    Do
                        If rFound Is Nothing Then
                            Exit Do
                        Else
                            lRow = lRow + 1
                            .Cells(lRow, 1) = oFolder & "\" & strFile
                            .Cells(lRow, 2) = wks.Name
                            .Cells(lRow, 3) = rFound.Address & temp
                            .Cells(lRow, 4) = rFound.Value
                        End If
                        Set rFound = wks.Cells.FindNext(After:=rFound)
                    Loop While strFirstAddress <> rFound.Address
                Next

                wbk.Close (False)
                strFile = Dir
            Loop

        Next oFile
    Loop


    .Columns("A:D").EntireColumn.AutoFit
End With
MsgBox "Done"
ExitHandler:
Set wOut = Nothing
Set wks = Nothing
Set wbk = Nothing
Set oFolder = Nothing
Set oSubfolder = Nothing
Set oFile = Nothing
Set queue = Nothing
Set fso = Nothing
Application.ScreenUpdating = True
Exit Sub

ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler

End Sub

Answer 1

For Each oFile In oFolder.Files
   strFile = Dir(oFolder & "\*.xls*")
   Do While strFile <> "" '***THIS IS THE LOOP WHERE I THINK THE PROBLAM IS
      ............
      strFile = Dir
   Loop
Next oFile

确实，您已经找到了错误所在。您在这里不需要两个嵌套循环，这就是生成重复项的原因。您应该使用这两种技术中的任何一种（使用Dir 或oFolder.Files 集合），但不能同时使用。

您的代码的快速修复是仅使用内部循环：

strFile = Dir(oFolder & "\*.xls*")
Do While strFile <> ""
    ......... ' <~~ leave insider code as is
    strFile = Dir
Loop