2010 macro runs slow in 2016 and display result is different

[jaswes]

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!

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