Consolidation of dynamically changing data in VBA

Question

I work with data including unique names of customers and values of their purchases. I want to conduct its consolidation, meaning the result would be customers and their total sums of purchase like in the picture below:

The data is changing after every VBA code operation (new customers come in, old disappear, new transactions are recorded etc.) which somehow leads to this line of code generating errors:

Sheets("Sheet1").Range(D2).Consolidate Sources:=Array(Sheet1!R2C1:R3C51), Function:=xlSum

Is there a different approach to this situation so that there's no problem with getting the right results?

Answer 1

Sum Up Unique

• Consider a table (not necessarily Excel table) with two columns: the first containing the keys and the second containing their values.
• These solutions will write the unique keys (not sorted) and the sum of their values to another table.
• Adjust the values in the constants section.

Remarks

• Note the 4th argument LeftColumn of Consolidate set to True:
  • True to consolidate data based on row titles in the left column of the consolidation ranges. False to consolidate data by position. The default value is False. (Microsoft Docs)
• Surprisingly, there is no need for the Array function most probably because there is only one range to consolidate.
• Although the Consolidate solution contains less code and maybe more 'user friendly' (easier to understand), it seems that the Dictionary version is more efficient (not tested properly).

The Code

Option Explicit

Sub sumUpDictionary()
    
    ' Constants
    Const srcName As String = "Sheet1"
    Const srcFirst As String = "A2"
    Const dstName As String = "Sheet1"
    Const dstFirst As String = "D2"
    Const cCount As Long = 2
    
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Source Range to Data Array.
    Dim cel As Range
    Dim Data As Variant
    With wb.Worksheets(srcName).Range(srcFirst)
        Set cel = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If cel Is Nothing Then Exit Sub
        Data = .Resize(cel.Row - .Row + 1, cCount)
    End With
    
    ' Data Array to Unique Sum Dictionary to Data Array.
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        Dim Key As Variant
        Dim i As Long
        For i = 1 To UBound(Data)
            Key = Data(i, 1)
            If Not IsError(Key) Then
                If Len(Key) > 0 Then
                    .Item(Key) = .Item(Key) + Data(i, 2)
                End If
            End If
        Next i
        If .Count = 0 Then Exit Sub
        ReDim Data(1 To .Count, 1 To cCount)
        i = 0
        For Each Key In .Keys
            i = i + 1
            Data(i, 1) = Key
            Data(i, 2) = .Item(Key)
        Next Key
    End With
    
    ' Data Array to Destination Range.
    With wb.Worksheets(dstName).Range(dstFirst).Resize(, cCount)
        .Resize(.Worksheet.Rows.Count - .Row + 1).ClearContents
        .Resize(i).Value = Data
    End With

End Sub

Sub sumUpConsolidate()
    
    ' Constants
    Const srcName As String = "Sheet1"
    Const srcFirst As String = "A2"
    Const dstName As String = "Sheet1"
    Const dstFirst As String = "D2"
    Const cCount As Long = 2
    
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Source
    Dim cel As Range
    Dim Data As Variant
    Dim consString  As String
    With wb.Worksheets(srcName).Range(srcFirst)
        Set cel = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If cel Is Nothing Then Exit Sub
        consString = "'" & .Worksheet.Name & "'" _
            & "!" & "R" & .Row & "C" & .Column _
            & ":" & "R" & cel.Row & "C" & .Column + cCount - 1
        ' or:
        'consString = "'" & .Worksheet.Name & "'" _
            & "!" & .Address(, , xlR1C1) _
            & ":" & cel.Resize(, cCount).Address(, , xlR1C1)
    End With
    
    ' Destination
    With wb.Worksheets(dstName).Range(dstFirst)
        .Resize(.Worksheet.Rows.Count - .Row + 1, cCount).ClearContents
        .Consolidate consString, xlSum, , True
    End With

End Sub

Answer 2

Use excel formulas instead of vba.

Fomula for D2:

=IFERROR(INDEX($A$3:$A$7, MATCH(0,COUNTIF($D$1:D1, $A$3:$A$7), 0)),"")

and hit CTR+SHIFT+ENTER

Then use sumif in E2:

=SUMIF($A$2:$A$7, D2, $B$2:$B$7)

Drop the cell down.