VBA - Create array of unique values and sum corresponding values

Question

Im looking for some help with a VBA problem I'm having. Basically, I'm collecting information from a source file on sheet1 into static arrays. From those static arrays I'm creating a dynamic array with account numbers, and a calculated value. What I'm trying to do next is create a second dynamic array with only unique account numbers and summing the calculated values in the previous dynamic array. But I have no idea how to do that...

The following is what I have so far.

   Dim ClosingCash() As Variant, MarginExcess() As Variant, VarMarg() As Variant, Acct() As Variant, FX() As Variant, UniqueAcct() As Variant, Answers() As Variant
 Dim Dim1 As Long, Counter As Long, W_Sum As Long

Sheet1.Activate

Acct = Range("b2", Range("b2").End(xlDown))
ClosingCash = Range("f2", Range("f2").End(xlDown))
MarginExcess = Range("j2", Range("J2").End(xlDown))
FX = Range("n2", Range("n2").End(xlDown))
VarMarg = Range("o2", Range("o2").End(xlDown))

Dim1 = UBound(ClosingCash, 1)

ReDim Answers(1 To Dim1, 1 To 2)

For Counter = 1 To Dim1
    Answers(Counter, 1) = Acct(Counter, 1)
    Answers(Counter, 2) = (WorksheetFunction.Min(ClosingCash(Counter, 1) + VarMarg(Counter, 1), MarginExcess(Counter, 1)) * FX(Counter, 1))
Next Counter

Sheet3.Activate
Range("a2", Range("a2").Offset(Dim1 - 1, 1)).Value = Answers

What I would like to print out are the unique account numbers, and the sum of Answers(counter, 2) that correspond to that account number, similar to a SumIf.

Any advise would be greatly appreciated!

question from:https://stackoverflow.com/questions/65910234/vba-create-array-of-unique-values-and-sum-corresponding-values

Answer 1

Sum Unique

• In your code you could use it like this:

  Dim Data As Variant: Data = getUniqueSum(Answers)
  If Not IsEmpty(Data) Then       
      Sheet3.Range("E2").Resize(UBound(Data, 1), UBound(Data, 2)).Value = Data
  End If
  

The Code

Option Explicit

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Writes the unique values from the first column of a 2D array
'               and the sum of the corresponding values in its second column,
'               to a 2D one-based two-columns array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function getUniqueSum( _
    Data As Variant) _
As Variant
    If IsEmpty(Data) Then Exit Function
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        Dim Key As Variant
        Dim i As Long
        Dim c1 As Long: c1 = LBound(Data, 2)
        Dim c2 As Long: c2 = c1 + 1
        For i = LBound(Data, 1) To UBound(Data, 1)
            Key = Data(i, c1)
            If Not IsError(Key) Then
                If Len(Key) > 0 Then
                    .Item(Key) = .Item(Key) + Data(i, c2)
                End If
            End If
        Next i
        If .Count = 0 Then Exit Function
        Dim Result As Variant: ReDim Result(1 To .Count, 1 To 2)
        i = 0
        For Each Key In .Keys
            i = i + 1
            Result(i, 1) = Key
            Result(i, 2) = .Item(Key)
        Next Key
        getUniqueSum = Result
    End With
End Function