I am working on something and I got stuck. I want to look for all xl files in my folder, and inside the subfolders of the folder, and look for a string, example "bbb" and prints all the files and cells where the string was found.
for example, I have a folder named "bla", inside three xl files, and also another folder "bla2", with 4 more xl files. it looks for "bbb" in all the files, and prints a new worksheet with the path of the file and the cell that match.
So, almost everything works, just it runs in one of my loops to many times, so it prints duplicate values.
Here is the code:
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
