quickly search value for multiple workbooks with specified sheets - excel

Question

Following the question:
VBA Excel - search multipe terms in workbooks with values matching to them
I would like to make a search for multiple workbooks across the directory, but with specified, repeatable sheets.
The full code:
Sub SearchFolders()
Dim xFso As Object
Dim xFld As Object
Dim xStrSearch As String
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 xCol As Long
Dim i As Long
Dim xFound As Range
Dim xStrAddress As String
Dim xFileDialog As FileDialog
Dim xUpdate As Boolean
Dim xCount As Long
Dim xAWB As Workbook
Dim xAWBStrPath As String
Dim xBol As Boolean
Set xAWB = ActiveWorkbook
'Set xWk = ActiveWorkbook.Worksheets("Civils*")
xAWBStrPath = xAWB.Path & "\" & xAWB.Name
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
'xStrSearch = "1366P"
xStrSearch = InputBox("Please provide the BoM Code")
xUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
Set xOut = Worksheets("SUMMARY")
xRow = 1
With xOut
.Cells(xRow, 1) = "Workbook"
.Cells(xRow, 2) = "Worksheet"
.Cells(xRow, 3) = "Cell"
.Cells(xRow, 4) = "Text in Cell"
.Cells(xRow, 5) = "Values corresponding"
Set xFso = CreateObject("Scripting.FileSystemObject")
Set xFld = xFso.GetFolder(xStrPath)
xStrFile = Dir(xStrPath & "\*.xls*")
Do While xStrFile <> ""
xBol = False
If (xStrPath & "\" & xStrFile) = xAWBStrPath Then
xBol = True
Set xWb = xAWB
Else
Set xWb = Workbooks.Open(Filename:=xStrPath & "\" & xStrFile, UpdateLinks:=0, ReadOnly:=True, AddToMRU:=False)
'Set xWk = Worksheets.Open("Civils Job Order")
End If
'For Each xWk In xWb.Worksheets("Civils Work Order")
For Each xWk In xWb.Worksheets
If xBol And (xWk.Name = .Name) Then
'If xBol And (xWk.Name = "Civils Work Order" Or xWk.Name = "Cable Works Order") Then
Else
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, 4) = xFound.Value
.Cells(xRow, 5).Range("A1").Value = xFound.EntireRow.Range("F1").Value
End If
Set xFound = xWk.Cells.FindNext(After:=xFound)
Loop While xStrAddress <> xFound.Address
End If
Next
If Not xBol Then
xWb.Close (False)
End If
xStrFile = Dir
Loop
.Columns("A:E").EntireColumn.AutoFit
End With
MsgBox xCount & " cells have been found", , "BoM Calculator for VM Greenfield"
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
There is no error coming in, but the Excel is frozen indefinitely.
Is it some solution for making this kind of search for the specified worksheet names, which occur regularly across all workbooks in the directory?

Answer 1

This is a bit lengthy, but a lot of the bulk is re-useable functions, so it lets you focus on the logic in the main method.
I'm guessing that the summary sheet is in the same workbook as this code, and that you're scanning a folder for files to summarize, one of which may already be open in Excel (so you don't want to open that again).
Compiles but not tested...
Sub SearchFolders()
Dim wbAct As Workbook, pathMainWb As String, fldrPath As String
Dim bom As String, scrUpdt, wsOut As Worksheet, colFiles As Collection, f As Object
Dim xBol As Boolean, wb As Workbook, ws As Worksheet, arrWs
Dim matchedCells As Collection, cell, numHits As Long, summRow As Long
Set wbAct = ActiveWorkbook
pathMainWb = wbAct.FullName '<<<<
On Error GoTo ErrHandler
fldrPath = UserSelectFolder("Select a folder")
If Len(fldrPath) = 0 Then Exit Sub
'get all files in the selected folder
Set colFiles = GetFileMatches(fldrPath, "*.xls*", False) 'False=no subfolders
If colFiles.Count = 0 Then
MsgBox "No Excel files found in selected folder"
Exit Sub
End If
bom = InputBox("Please provide the BoM Code")
scrUpdt = Application.ScreenUpdating
Application.ScreenUpdating = False
Set wsOut = ThisWorkbook.Worksheets("SUMMARY")
summRow = 1
'sheet names to scan
arrWs = Array("Civils Job Order", "Civils Work Order", "Cable Works Order")
wsOut.Cells(summRow, 1).Resize(1, 5).Value = Array("Workbook", "Worksheet", _
"Cell", "Text in Cell", "Values corresponding")
For Each f In colFiles
xBol = (f.Path = pathMainWb) 'file already open?
If xBol Then
Set wb = wbAct
Else
Set wb = Workbooks.Open(Filename:=f.Path, UpdateLinks:=0, _
ReadOnly:=True, AddToMRU:=False)
End If
For Each ws In wb.Worksheets
'are we interested in this sheet?
If Not IsError(Application.Match(ws.Name, arrWs, 0)) Then
Set matchedCells = FindAll(ws.UsedRange, bom) 'get all cells with bom
If matchedCells.Count > 0 Then
For Each cell In matchedCells
summRow = summRow + 1
wsOut.Cells(summRow, 1).Resize(1, 5).Value = _
Array(wb.Name, ws.Name, cell.Address, cell.Value, _
cell.EntireRow.Range("F1").Value)
numHits = numHits + 1
Next cell 'next match
End If 'any bom matches
End If 'matched sheet name
Next ws
If Not xBol Then wb.Close False 'need to close this workbook?
Next f
wsOut.Columns("A:E").EntireColumn.AutoFit
MsgBox numHits & " cells have been found", , "BoM Calculator for VM Greenfield"
ExitHandler:
Application.ScreenUpdating = scrUpdt
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub
'ask the user to select a folder
Function UserSelectFolder(msgPrompt As String) As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = msgPrompt
If .Show = -1 Then UserSelectFolder = .SelectedItems(1) & "\"
End With
End Function
'Return a collection of file objects given a starting folder and a file pattern
' e.g. "*.txt"
'Pass False for last parameter if don't want to check subfolders
Function GetFileMatches(startFolder As String, filePattern As String, _
Optional subFolders As Boolean = True) As Collection
Dim fso, fldr, f, subFldr, fpath
Dim colFiles As New Collection
Dim colSub As New Collection
Set fso = CreateObject("scripting.filesystemobject")
colSub.Add startFolder
Do While colSub.Count > 0
Set fldr = fso.getfolder(colSub(1))
colSub.Remove 1
If subFolders Then
For Each subFldr In fldr.subFolders
colSub.Add subFldr.Path
Next subFldr
End If
fpath = fldr.Path
If Right(fpath, 1) <> "\" Then fpath = fpath & "\"
f = Dir(fpath & filePattern) 'Dir is faster...
Do While Len(f) > 0
colFiles.Add fso.getfile(fpath & f)
f = Dir()
Loop
Loop
Set GetFileMatches = colFiles
End Function
'search range `rng` for all matches to `val` and return
' as a Collection of ranges (cells)
Public Function FindAll(rng As Range, val As String) 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