Search for multiple strings across multiple workbooks and copy data - excel

Question

I have borrowed some code that searches multiple excel workbooks for a string and tried to modify it to search for multiple strings instead. Unfortunately it seems to stop after searching for the first item in the array.
Sub SearchFolders()
'Dim myArray As Variant
'Dim myCounter As Long
Dim xFso As Object
Dim xFld As Object
Dim xStrSearch As Variant
Dim xStrPath As String
Dim xStrFile As String
Dim xOut As Worksheet
Dim xWb As Workbook
Dim xWk As Worksheet
Dim xRow As Long
Dim xFound As Range
Dim xStrAddress As Variant
Dim xFileDialog As FileDialog
Dim xUpdate As Boolean
Dim xCount As Long
myArray = Array("item a", "item b", "item c", "item d")
On Error GoTo ErrHandler
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a Folder"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
xUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
Set xOut = Worksheets.Add
For myCounter = 0 To UBound(myArray)
MsgBox myCounter & "is the count no."
xStrSearch = myArray(myCounter)
MsgBox xStrSearch & "is the string"
xRow = 1
With xOut
.Cells(xRow, 1) = "Workbook"
.Cells(xRow, 2) = "Worksheet"
.Cells(xRow, 3) = "Cell"
.Cells(xRow, 4) = "Filler"
.Cells(xRow, 5) = "Text in Cell"
Set xFso = CreateObject("Scripting.FileSystemObject")
Set xFld = xFso.GetFolder(xStrPath)
xStrFile = Dir(xStrPath & "\*.xls*")
Do While xStrFile <> ""
Set xWb = Workbooks.Open(Filename:=xStrPath & "\" & xStrFile, _
UpdateLinks:=0, ReadOnly:=True, AddToMRU:=False)
For Each xWk In xWb.Worksheets
Set xFound = xWk.UsedRange.Find(xStrSearch)
If Not xFound Is Nothing Then
xStrAddress = xFound.Address
End If
Do
If xFound Is Nothing Then
Exit Do
Else
xCount = xCount + 1
xRow = xRow + 1
.Cells(xRow, 1) = xWb.Name
.Cells(xRow, 2) = xWk.Name
.Cells(xRow, 3) = xFound.Address
.Cells(xRow, 5) = xFound.Value
End If
Set xFound = xWk.Cells.FindNext(After:=xFound)
Loop While xStrAddress <> xFound.Address
myCounter = myCounter + 1
Next
xWb.Close (False)
xStrFile = Dir
Loop
.Columns("A:D").EntireColum.AutoFit
End With
Next myCounter
MsgBox xCount & "Cells have been found", , "filler"
ExitHandler:
Set xOut = Nothing
Set xWk = Nothing
Set xWb = Nothing
Set xFld = Nothing
Set xFso = Nothing
Application.ScreenUpdating = xUpdate
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub
Not sure what I've done wrong.
If possible, it would be great to also be able to return the value of Column A or copy Columns A - H into the sheet.
I.e. If found.address is (C,4) then also return (A,4).
Many thanks!

Answer 1

Whenever you have a situation where your code does multiple things like:
ask for a folder
find all files in that folder
find all cell matches in each sheet in each file
you're better off pushing any functionality which can be wrapped in its own sub/function into a stand-alone method, so you can focus on your actual task and its logic, instead of having it overwhelmed by all of the sub-tasks and their logic/rules.
Plus, once you've created your focused sub-methods, you can re-use them later.
Applying that approach to your task:
Sub SearchFolders()
Dim arrSearch As Variant
Dim rw As Long, s
Dim folderPath As String, f, allFiles As Collection, allCells As Collection
Dim wb As Workbook, ws As Worksheet, wsOut As Worksheet, c
arrSearch = Array("item a", "item b", "item c", "item d")
folderPath = SelectFolder() 'get a folder from the user
If Len(folderPath) = 0 Then Exit Sub 'no selected folder
Set allFiles = MatchingFiles(folderPath, "*.xls*") 'find all matching files
If allFiles.Count = 0 Then
MsgBox "No matching files found!"
Exit Sub
End If
Set wsOut = ThisWorkbook.Worksheets.Add()
wsOut.Range("A1:E1").Value = Array("Workbook", "Worksheet", _
"Cell", "Filler", "Cell Text")
rw = 2
For Each f In allFiles 'loop files
With Workbooks.Open(f, ReadOnly:=True)
For Each ws In .Worksheets 'loop workbooks
For Each s In arrSearch 'loop search terms
Set allCells = FindAll(ws.UsedRange, s)
For Each c In allCells 'loop matches
wsOut.Cells(rw, 1).Resize(1, 5).Value = _
Array(.Name, ws.Name, c.Address, "", c.Value)
wsOut.Cells(rw, 6).Resize(1, 8).Value = _
c.entirerow.cells(1).resize(1, 8) 'copy A-H from row with c
rw = rw + 1
Next c
Next s 'next search string
Next ws 'next worksheet
.Close False
End With
Next f 'next workbook
wsOut.Range("A:D").EntireColumn.AutoFit
End Sub
'ask the user for a folder
Function SelectFolder() As String
Dim rv As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Select a Folder"
If .Show = -1 Then rv = .SelectedItems(1)
End With
If Right(rv, 1) <> "\" Then rv = rv & "\" 'ensure trailing "\"
SelectFolder = rv
End Function
'Return a collection of all files in folder `fPath` matching `pattern`
Function MatchingFiles(fPath As String, pattern As String)
Dim f As Object, col As New Collection
With CreateObject("scripting.filesystemobject").getfolder(fPath)
For Each f In .Files
If f.Name Like pattern Then col.Add f.Path
Next f
End With
Set MatchingFiles = col
End Function
'Find all matches in a range and return as a collection of cells
'Note: adjust the Find() parameters to function as you need
' (eg. exact vs partial match)
Public Function FindAll(rng As Range, val) As Collection
Dim rv As New Collection, f As Range
Dim addr As String
Set f = rng.Find(what:=val, after:=rng.Cells(rng.Cells.Count), _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
If Not f Is Nothing Then addr = f.Address()
Do Until f Is Nothing
rv.Add f
Set f = rng.FindNext(after:=f)
If f.Address() = addr Then Exit Do
Loop
Set FindAll = rv
End Function