在Excel 2016中加快VBA搜索

时间：2018-09-27 14:53:52

标签： excel vba

我有以下（请参见下文）在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

2 个答案:

答案 0 :(得分：0)

只想包括OP here提到的解决方案，因为它位于不同的论坛上。

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

答案 1 :(得分：0)

您正在测试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

相关问题
最新问题