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

迭代文件和子文件夹，并查找文本

1 个答案: