慢查找宏

Question

我有一个包含 84 sheet 的工作簿。在每个 sheet 中有 2 列。第一列是应用程序名称，第二列是它的版本。

我写了一个宏来获取应用程序列表，这是我第一次写。它工作正常，但速度非常慢。我以前从未与 VBA 合作过，所以我可能做错了什么。

我试图完成的是获取已安装应用程序的摘要报告。它在 Application Report sheet 中搜索每个 sheet 中的每一行。如果它不在列表中，它会添加一个新行，然后将 1 作为其计数。如果应用程序在列表中，它会将其计数加 1。

Sub CombineAllPrograms()
Dim ws As Worksheet
Dim Rapor As Worksheet
Dim xApp As String
Dim xi As Integer
Dim xRi As Integer
Dim xLast As Integer
Dim xRange As range

Set Rapor = Sheets("Application Report")
xRi = 1

Application.ScreenUpdating = False

For Each ws In Sheets
    If ws.Name = "Application Report" Then GoTo ContinueLoop
    For xi = 3 To 30
        If ws.Cells(xi, "I") = vbNullString Then Exit For
        
        xApp = ws.Cells(xi, "I").Value & " " & ws.Cells(xi, "J").Value
        
        With Rapor.range("A:A")
            Set xRange = .Find(xApp, LookAt:=xlWhole, SearchOrder:=xlByRows)
            If xRange Is Nothing Then
                Rapor.Cells(xRi, "A").Value = xApp
                Rapor.Cells(xRi, "B").Value = ws.Cells(xi, "I").Value
                Rapor.Cells(xRi, "C").Value = ws.Cells(xi, "J").Value
                Rapor.Cells(xRi, "D").Value = 1
                xRi = xRi + 1
            Else
                Rapor.Cells(xRange.Row, "D").Value = Rapor.Cells(xRange.Row, "D").Value + 1
            End If
        End With
        
    Next xi
    
ContinueLoop:
Next

Application.ScreenUpdating = True

End Sub

我怎样做才能让它更快？也许我选择了一个慢速的方法，还有更好的方法吗？

Answer 1

计算唯一值

双字典解决方案

Option Explicit

Sub writeReport()

    Const dName As String = "Application Report"
    Const dFirst As String = "A2" ' four adjacent columns
    Const sFirst As String = "I3" ' two adjacent columns
    Const Delimiter As String = " "
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' Workbook containing this code.
    
    ' Write from Source Range to Data Array, then to the dictionaries.
    
    ' Application/Version (Main) Dictionary
    Dim dictAV As Object: Set dictAV = CreateObject("Scripting.Dictionary")
    dictAV.CompareMode = vbTextCompare
    ' Count Dictionary
    Dim dictC As Object: Set dictC = CreateObject("Scripting.Dictionary")
    ' Application/Version Array
    Dim AppVer As Variant: ReDim AppVer(2 To 3)
    
    Dim sws As Worksheet
    Dim srg As Range
    Dim Data As Variant
    Dim Key As Variant '
    Dim i As Long
    
    For Each sws In wb.Worksheets
        If Not StrComp(sws.Name, dName, vbTextCompare) Then
            With sws.Range(sFirst)
                Set srg = .Resize(sws.Rows.Count - .Row + 1) _
                    .Find("*", , xlFormulas, , , xlPrevious)
                If Not srg Is Nothing Then
                    Data = .Resize(srg.Row - .Row + 1, 2).Value
                    For i = 1 To UBound(Data, 1)
                        If isValue(Data(i, 1)) Then
                            If isValue(Data(i, 2)) Then
                                Key = Data(i, 1) & Delimiter & Data(i, 2)
                                AppVer(3) = Data(i, 2)
                            Else
                                Key = Data(i, 1)
                                AppVer(3) = ""
                            End If
                            If dictAV.Exists(Key) Then
                                dictC(Key) = dictC(Key) + 1
                            Else
                                AppVer(2) = Data(i, 1)
                                dictAV(Key) = AppVer
                                dictC(Key) = 1
                            End If
                        End If
                    Next i
                End If
            End With
        End If
    Next sws
    If dictAV.Count = 0 Then Exit Sub
    
    ' Write from dictionaries to Data Array.
    
    ReDim Data(1 To dictAV.Count, 1 To 4)
    i = 0
    
    Dim j As Long
    
    For Each Key In dictAV.Keys
        i = i + 1
        Data(i, 1) = Key
        For j = 2 To 3
            Data(i, j) = dictAV(Key)(j)
        Next j
        Data(i, 4) = dictC(Key)
    Next Key
    
    ' Write from Data Array to Destination Range.
    
    With wb.Worksheets(dName).Range(dFirst).Resize(, 4)
        .Resize(.Worksheet.Rows.Count - .Row + 1).ClearContents
        .Resize(i).Value = Data
    End With
    
End Sub

Function isValue( _
    CheckValue As Variant) _
As Boolean
    If Not IsError(CheckValue) Then
        If Len(CheckValue) > 0 Then
            isValue = True
        End If
    End If
End Function

Answer 2

Match 比 Find 快，您可以通过 reading/writing 使用数组而不是逐个单元来获得更多改进

Sub CombineAllPrograms()

    Dim ws As Worksheet, Rapor As Worksheet
    Dim xApp As String
    Dim xi As Long, xRi As Long
    Dim m, arr
    
    Set Rapor = ThisWorkbook.Sheets("Application Report")
    xRi = 1
    
    Application.ScreenUpdating = False
    
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> Rapor.Name Then 'no Goto required...
            
            arr = ws.Range("I3:J30").Value 'one read
            'loop over array, not range
            For xi = 1 To UBound(arr, 1)
                
                If Len(arr(xi, 1)) = 0 Then Exit For
                xApp = arr(xi, 1) & " " & arr(xi, 2)
                
                m = Application.Match(xApp, Rapor.Range("A:A"), 0)
                If IsError(m) Then
                    'no match made: one write not 4
                    Rapor.Cells(xRi, "A").Resize(1, 4).Value = Array(xApp, arr(xi, 1), arr(xi, 2), 1)
                Else
                    With Rapor.Cells(m, "D")
                        .Value = .Value + 1
                    End With
                End If
            Next xi
        End If 'not Application Report
    Next       'worksheet
    
    Application.ScreenUpdating = True

End Sub

慢查找宏

Slow find macro

excel

vba

find

计算唯一值