Slow find macro

Question

I have a workbook that has 84 sheets in it. In each sheet there are 2 columns. First column is application name and second column is its version.

I wrote a macro to get list of applications which is my first time writing. It works fine but its painfully slow. I never have worked with VBA before so I might did something wrong.

What I tried to accomplish is to get a summary report of installed apps. It searches the Application Report sheet for every row in each sheet. If it isn't in the list, it adds a new row and then puts 1 as its count. If the application is in the list, it adds up 1 to its count.

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

What can I do to make it faster? Maybe I chosee a slow method and there is a better way?

user_478884 · Answer

Match is faster than Find, and you can get more improvement by reading/writing using arrays and not cell-by-cell

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

user_9814069 · Answer

Count Unique Values

A Double Dictionary Solution

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

Slow find macro

2 Answers

Count Unique Values