2010 macro runs slow in 2016 and display result is different
Hello,
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. As a side note, on Many occasions I have received top notch help on this forum, and have met the nicest of people... Thank you!
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
Link to Test Data and Search Utility Workbook
