Speed up a VBA search in Excel 2016 - excel

Question

I have the following(see below) "File Search Utility" macro that I have been using in Excel 2010. This macro searches through a specified folder of workbooks and returns the desired data (love this macro!).
In Excel 2010, the search (which searches 450+ files) takes about 2 minutes and displays the results AS they are found.
In Excel 2016, the search takes more than double the time, and no results are displayed until the macro has completely run through all of the files in the folder.
I am a novice to intermediate macro programmer at best (i.e. I know enough to be dangerous). Any help to tweak this code would be greatly appreciated.
Here is the Code:
Option Explicit
Public Sub SearchButton_Click()
Dim astrWorkbooks() As String
Dim strPartNumber As String
Dim strFolderPath As String
Dim vntWorkbooks As Variant
Dim j As Long
On Error GoTo ErrHandler
If Not ValidateData("PartNumber", strPartNumber) Then
MsgBox "Part number has not been entered.", vbExclamation
Exit Sub
End If
If Not ValidateData("SearchFolder", strFolderPath) Then
MsgBox "Search folder has not been entered.", vbExclamation
Exit Sub
End If
Call ClearResultsTable
If Not FolderExists(strFolderPath) Then
MsgBox "Search folder does not exist.", vbExclamation
Exit Sub
End If
vntWorkbooks = GetAllWorkbooks(strFolderPath)
If IsEmpty(vntWorkbooks) Then
MsgBox "Search folder does not contain any Excel workbooks.", vbExclamation
Exit Sub
End If
astrWorkbooks = vntWorkbooks
For j = LBound(astrWorkbooks) To UBound(astrWorkbooks)
Call SearchWorkbook(astrWorkbooks(j), strPartNumber)
Next j
MsgBox "Search has completed. Please check results table.", vbInformation
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
End Sub
Private Function FolderExists(ByRef strFolderPath As String) As Boolean
On Error GoTo ErrHandler
If Right(strFolderPath, 1) <> Application.PathSeparator Then
strFolderPath = strFolderPath & Application.PathSeparator
End If
FolderExists = (Dir(strFolderPath, vbDirectory) <> "")
Exit Function
ErrHandler:
FolderExists = False
End Function
Private Sub ClearResultsTable()
Dim tblResults As ListObject
Dim objFilter As AutoFilter
Dim rngBody As Range
Set tblResults = wksSearchUtility.ListObjects("Results")
Set objFilter = tblResults.AutoFilter
Set rngBody = tblResults.DataBodyRange
If Not objFilter Is Nothing Then
If objFilter.FilterMode Then
objFilter.ShowAllData
End If
End If
If Not rngBody Is Nothing Then
rngBody.Delete
End If
End Sub
Private Function ValidateData(ByVal strRangeName As String, ByRef strData As String) As Boolean
On Error GoTo ErrHandler
strData = UCase(Trim(wksSearchUtility.Range(strRangeName).Text))
ValidateData = (strData <> vbNullString)
Exit Function
ErrHandler:
ValidateData = False
End Function
Private Function GetAllWorkbooks(strFolderPath As String) As Variant
Dim lngWorkbookCount As Long
Dim astrWorkbooks() As String
Dim strFileName As String
Dim strFilePath As String
On Error GoTo ErrHandler
strFileName = Dir(strFolderPath & "*.xl*")
Do Until (strFileName = vbNullString)
lngWorkbookCount = lngWorkbookCount + 1
strFilePath = strFolderPath & strFileName
ReDim Preserve astrWorkbooks(1 To lngWorkbookCount)
astrWorkbooks(lngWorkbookCount) = strFilePath
strFileName = Dir()
Loop
If lngWorkbookCount > 0 Then
GetAllWorkbooks = astrWorkbooks
Else
GetAllWorkbooks = Empty
End If
Exit Function
ErrHandler:
GetAllWorkbooks = Empty
End Function
Private Sub SearchWorkbook(strFilePath As String, strPartNumber As String)
Dim sht As Worksheet
Dim wbk As Workbook
On Error GoTo ErrHandler
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set wbk = Workbooks.Open(strFilePath, False)
For Each sht In wbk.Worksheets
Call SearchWorksheet(sht, strPartNumber)
Next sht
ExitProc:
On Error Resume Next
wbk.Close False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
ErrHandler:
Resume ExitProc
End Sub
Private Sub SearchWorksheet(sht As Worksheet, strPartNumber As String)
Dim rngTableRow As Range
Dim cell As Range
On Error GoTo ErrHandler
For Each cell In Intersect(sht.Columns("B"), sht.UsedRange).Cells
If UCase(cell.Text) Like "*" & strPartNumber & "*" Then
Set rngTableRow = GetNextRow()
rngTableRow.Item(1).Value = sht.Parent.Name
rngTableRow.Item(2).Value = cell.Text
rngTableRow.Item(3).Value = cell.Offset(, -1).Value
rngTableRow.Item(4).Value = cell.Offset(, 6).Value
rngTableRow.Item(5).Value = cell.Offset(, 7).Value
rngTableRow.Item(6) = Range("I3")
End If
Next cell
Exit Sub
ErrHandler:
End Sub
Private Function GetNextRow() As Range
With wksSearchUtility.ListObjects("Results")
If .InsertRowRange Is Nothing Then
Set GetNextRow = .ListRows.Add.Range
Else
Set GetNextRow = .InsertRowRange
End If
End With
End Function

Answer 1

You are testing every single cell in column B, that's the performance killer. Check this post for how to do this using the find function, it will be WAY faster.
Find all matches in workbook using Excel VBA
Where the code in that answer defines loc, replace .cells with Intersect(sht.Columns("B"), sht.UsedRange)
it should read something like this:
Set Loc = Intersect(sht.Columns("B"), sht.UsedRange).Find(What:="Question?")
And obviously "Question" will become strPartNumber

Answer 2

Just wanted to include the solution mentioned by OP here as it is located on a different forum.
Option Explicit
Public Sub SearchButton_Click()
Dim astrWorkbooks() As String, strPartNumber As String, strFolderPath As String, vntWorkbooks As Variant
Dim j As Long, BlockSize As Long, myRng As Range, BigRng As Range, TempSht As Worksheet, i, myFormula As String, yyy As Range
Dim Drng As Range, SceRng As Range, Destn As Range, msg As String
Application.ScreenUpdating = False
On Error GoTo ErrHandler
If Not ValidateData("PartNumber", strPartNumber) Then
MsgBox "Part number has not been entered.", vbExclamation
Exit Sub
End If
If Not ValidateData("SearchFolder", strFolderPath) Then
MsgBox "Search folder has not been entered.", vbExclamation
Exit Sub
End If
Call ClearResultsTable
If Not FolderExists(strFolderPath) Then
MsgBox "Search folder does not exist.", vbExclamation
Exit Sub
End If
vntWorkbooks = GetAllWorkbooks(strFolderPath)
If IsEmpty(vntWorkbooks) Then
MsgBox "Search folder does not contain any Excel workbooks.", vbExclamation
Exit Sub
End If
Set TempSht = Sheets.Add
astrWorkbooks = vntWorkbooks
BlockSize = 37
For i = 1 To UBound(astrWorkbooks)
myFormula = "='" & strFolderPath & "[" & astrWorkbooks(i) & "]Invoice'!R2C1:R" & BlockSize + 1 & "C9"
Set myRng = TempSht.Range("B" & BlockSize * i - BlockSize + 1).Resize(BlockSize, 9)
myRng.FormulaArray = myFormula
myRng.Offset(, -1).Resize(, 1).Value = astrWorkbooks(i)
myFormula = "='" & strFolderPath & "[" & astrWorkbooks(i) & "]Invoice'!R3C9"
myRng.Columns(myRng.Columns.Count).Offset(, 1).FormulaR1C1 = myFormula
If BigRng Is Nothing Then Set BigRng = myRng Else Set BigRng = Union(BigRng, myRng)
Next i
Set BigRng = BigRng.Offset(, -1).Resize(, BigRng.Columns.Count + 2)
BigRng.Value = BigRng.Value
With TempSht
.Columns("D:H").Delete
.Columns("C:C").Cut
.Columns("B:B").Insert
BigRng.AutoFilter Field:=2, Criteria1:="=*" & strPartNumber & "*"
Set yyy = .AutoFilter.Range
If yyy.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
Set Drng = .Range("A" & yyy.Rows.Count + 10)
yyy.Offset(1).Resize(yyy.Rows.Count - 1).Copy Drng
Set SceRng = Drng.CurrentRegion
Set Destn = GetNextRow.Resize(SceRng.Rows.Count)
Destn.Value = SceRng.Value
msg = "Search has completed. Please check results table."
Else
msg = "Search has completed. No results found"
End If
Application.DisplayAlerts = False: .Delete: Application.DisplayAlerts = True
End With
Application.ScreenUpdating = True
MsgBox msg, vbInformation
Exit Sub
ErrHandler:
Application.ScreenUpdating = True
MsgBox Err.Description, vbExclamation
End Sub
Private Function FolderExists(ByRef strFolderPath As String) As Boolean
On Error GoTo ErrHandler
If Right(strFolderPath, 1) <> Application.PathSeparator Then
strFolderPath = strFolderPath & Application.PathSeparator
End If
FolderExists = (Dir(strFolderPath, vbDirectory) <> "")
Exit Function
ErrHandler:
FolderExists = False
End Function
Private Sub ClearResultsTable()
Dim tblResults As ListObject
Dim objFilter As AutoFilter
Dim rngBody As Range
Set tblResults = wksSearchUtility.ListObjects("Results")
Set objFilter = tblResults.AutoFilter
Set rngBody = tblResults.DataBodyRange
If Not objFilter Is Nothing Then
If objFilter.FilterMode Then
objFilter.ShowAllData
End If
End If
If Not rngBody Is Nothing Then
rngBody.Delete
End If
End Sub
Private Function ValidateData(ByVal strRangeName As String, ByRef strData As String) As Boolean
On Error GoTo ErrHandler
strData = UCase(Trim(wksSearchUtility.Range(strRangeName).Text))
ValidateData = (strData <> vbNullString)
Exit Function
ErrHandler:
ValidateData = False
End Function
Private Function GetNextRow() As Range
With wksSearchUtility.ListObjects("Results")
If .InsertRowRange Is Nothing Then
Set GetNextRow = .ListRows.Add.Range
Else
Set GetNextRow = .InsertRowRange
End If
End With
End Function
Private Function GetAllWorkbooks(strFolderPath As String) As Variant
Dim lngWorkbookCount As Long
Dim astrWorkbooks() As String
Dim strFileName As String
Dim strFilePath As String
On Error GoTo ErrHandler
strFileName = Dir(strFolderPath & "*.xl*")
Do Until (strFileName = vbNullString)
lngWorkbookCount = lngWorkbookCount + 1
ReDim Preserve astrWorkbooks(1 To lngWorkbookCount)
astrWorkbooks(lngWorkbookCount) = strFileName
strFileName = Dir()
Loop
If lngWorkbookCount > 0 Then
GetAllWorkbooks = astrWorkbooks
Else
GetAllWorkbooks = Empty
End If
Exit Function
ErrHandler:
GetAllWorkbooks = Empty
End Function