My code for conditional sum in vba is showing error

Question

Dim wb As Workbook
Dim ws As Worksheet                        'for looping worksheets
Dim i As Double    
Dim lastrowG As Long
Dim lastrow As Double

Set wb = ThisWorkbook

For Each ws In ThisWorkbook.Worksheets

    lastrow = ws.Cells(Rows.Count, "A").End(xlUp).Row
    lastrowG = ws.Cells(Rows.Count, "G").End(xlUp).Row

            For i = 2 To lastrow                                                                        
                   ws.Cells(i, 12).Value = WorksheetFunction.SumIf(ws.Range("A1:A" & lastrow), ws.Cells(i, 9), ws.Range("G1:G" & lastrowG))
            Next i
Next ws

End Sub

I want to compare column A data with column I. If the data is equal, then I want to add the data of column G and show it in column L.I am not getting any error but it finally ends in excel not responding. The data in column A and I are strings. it's a 94000 rows data. Does anybody know what could be the reason?

Answer 1

A VBA SumIf: Sum Per Category

The Calling Procedure

Sub RetrieveSumsPerCategory()
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim ws As Worksheet
    
    For Each ws In wb.Worksheets
        SumPerCategory ws
    Next ws
            
    MsgBox "Sums per category retrieved.", vbInformation

End Sub

Main

' Performs a 'SumIf' on a single worksheet.
Sub SumPerCategory(ByVal ws As Worksheet)

    ' Define constants.
    Const SRC_LOOKUP_COLUMN As String = "A" ' 2. ... here...
    Const SRC_RETURN_COLUMN As String = "G" ' 3. ... and return this...
    Const DST_LOOKUP_COLUMN As String = "I" ' 1. Look for this...
    Const DST_RETURN_COLUMN As String = "L" ' 4. ... here.
    Const FIRST_ROW As Long = 2

    ' Reference the source ranges.
    Dim slrg As Range, srrg As Range, sRowsCount As Long
    With ws.Cells(FIRST_ROW, SRC_LOOKUP_COLUMN)
        sRowsCount = ws.Cells(ws.Rows.Count, .Column) _
            .End(xlUp).Row - .Row + 1
        If sRowsCount < 1 Then Exit Sub ' no source lookup data
        Set slrg = .Resize(sRowsCount)
        Set srrg = slrg.EntireRow.Columns(SRC_RETURN_COLUMN)
    End With
    
    ' Reference the destination ranges.
    Dim dlrg As Range, drrg As Range, dRowsCount As Long
    With ws.Cells(FIRST_ROW, DST_LOOKUP_COLUMN)
        dRowsCount = ws.Cells(ws.Rows.Count, .Column) _
            .End(xlUp).Row - .Row + 1
        If dRowsCount < 1 Then Exit Sub ' no destination lookup data
        Set dlrg = .Resize(dRowsCount)
        Set drrg = dlrg.EntireRow.Columns(DST_RETURN_COLUMN)
    End With
    
    ' Clear existing data in the destination return column.
    drrg.ClearContents ' keep formatting, or not 'drrg.Clear'
    
    ' Return the source lookup and return values in arrays.
    Dim lData() As Variant: lData = GetRange(slrg)
    Dim rData() As Variant: rData = GetRange(srrg)
    
    ' Define a dictionary whose keys will hold the unique lookup values
    ' as strings and whose items will hold the corresponding sums for each key.
    Dim sdict As Object: Set sdict = CreateObject("Scripting.Dictionary")
    sdict.CompareMode = vbTextCompare ' A=a
    
    ' Loop through the rows of the source arrays and populate the dictionary.
    Dim r As Long, Value As Variant, lString As String, rNumber As Double
    For r = 1 To sRowsCount
        Value = lData(r, 1)
        If IsNoErrorNoBlank(Value) Then
            lString = CStr(Value)
            Value = rData(r, 1)
            rNumber = 0
            If IsNoErrorNoBlank(Value) Then
                If IsNumeric(Value) Then rNumber = CDbl(Value)
            End If
            sdict(lString) = sdict(lString) + rNumber
        End If
    Next r
    If sdict.Count = 0 Then Exit Sub ' no matches
    
    ' Return the destination lookup values in an array and define
    ' the destination return array.
    lData = GetRange(dlrg)
    ReDim rData(1 To dRowsCount, 1 To 1)
    
    ' Loop through the rows of the destination arrays
    ' and lookup each value of the lookup array in the dictionary keys.
    ' If found, return the value of the corresponding item, the sum,
    ' in the same row of the destination array.
    For r = 1 To dRowsCount
        Value = lData(r, 1)
        If IsNoErrorNoBlank(Value) Then
            lString = CStr(Value)
            If sdict.Exists(lString) Then rData(r, 1) = sdict(lString)
        End If
    Next r
    
    ' Write the values of the destination return array
    ' to the destination return range.
    drrg.Value = rData

End Sub

Help

' Returns the values of a (single-area) range in a 2D one-based array.
Function GetRange(ByVal rg As Range) As Variant
    With rg.Areas(1)
        If .Cells.CountLarge = 1 Then
            Dim Data() As Variant: ReDim Data(1 To 1, 1 To 1)
            Data(1, 1) = .Value
            GetRange = Data
        Else
            GetRange = .Value
        End If
    End With
End Function

' Returns a boolean indicating whether a value is not an error or a blank.
Function IsNoErrorNoBlank(ByVal Value As Variant) As Boolean
    If IsError(Value) Then Exit Function
    If Len(Value) = 0 Then Exit Function
    IsNoErrorNoBlank = True
End Function

Answer 2

"Excel not responding" means probably that Excel is still busy with calculation. Having > 90k rows in Col A and Col I means at the end of the day that more than 8 billion comparisons needs to be done (every value in Col A with every value in Col I). That takes time...

I have quickly created a different attempt:

• In a first step, read all values from col A, col I and col G into memory.

• Now build a dictionary of all values of col G and sum up all values of col G.

• Third step is to loop over all values in col A and check if the dictionary has an entry for that value.

• Last step is to write the results back to the sheet (into col L)

Relevant piece of the code:

With ws
    ' Read Data into arrays
    Dim Col1Data, Col2Data, NumData, ResultData
    Dim col1RowCount As Long, col2RowCount As Long
    col1RowCount = .Cells(.Rows.Count, "A").End(xlUp).row
    Col1Data = .Range("A2:A" & col1RowCount)
    col2RowCount = .Cells(.Rows.Count, "G").End(xlUp).row
    Col2Data = .Range("I2:I" & col2RowCount)
    NumData = .Range("G2:G" & col2RowCount)

    Dim sumDict As Dictionary
    Set sumDict = New Dictionary
    
    ' Loop over the data in Col2 (=I) and calculate the sum for every value
    Dim row As Long
    Dim key As String, value As Double
    For row = 1 To UBound(Col2Data)
        key = Col2Data(row, 1)
        value = NumData(row, 1)
        sumDict(key) = sumDict(key) + value
    Next
    
    ' Get the sum of every value Col1 (=A)
    ReDim ResultData(1 To UBound(Col1Data), 1 To 1)
    For row = 1 To UBound(Col1Data)
        key = Col1Data(row, 1)
        If sumDict.Exists(key) Then ResultData(row, 1) = sumDict(key)
    Next
    
    ' Write back result to dest column (=L)
    .Range("L2").Resize(UBound(Col1Data), 1) = ResultData
End With

Add a reference to the Microsoft Scripting Runtime (or use Late Binding) to make the code work (drawback: Scripting Runtime and therefore Dictionaries doesn't exist on a Mac).

I created a test sheet with 100.000 rows, both for col A and G. Runtime was maybe 1/2 second.

N.B.: In your code, change data type for i and lastrow to Long