excel - 在 Excel 2016 中加快 VBA 搜索

Question

我有以下(见下文)我一直在 Excel 2010 中使用的“文件搜索实用程序”宏。这个宏搜索指定的工作簿文件夹并返回所需的数据(喜欢这个宏!)。

在 Excel 2010 中，搜索(搜索 450 多个文件)大约需要 2 分钟，并在找到时显示结果。

在 Excel 2016 中，搜索需要两倍以上的时间，并且在宏完全遍历文件夹中的所有文件之前不会显示任何结果。

我充其量只是中级宏程序员的新手(即我知道足够危险)。任何调整此代码的帮助将不胜感激。

这是代码:

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

您正在测试 B 列中的每个单元格，这是性能杀手。查看这篇文章以了解如何使用 find 功能执行此操作，它会更快。

Find all matches in workbook using Excel VBA

该答案中的代码定义 loc , 替换 .cells与 Intersect(sht.Columns("B"), sht.UsedRange)
它应该是这样的:

    Set Loc = Intersect(sht.Columns("B"), sht.UsedRange).Find(What:="Question?")

显然 "Question"将变为 strPartNumber