Trying to adapt vba code range and dict object to sum any items of the same key-CodePudding

I have some code that I had gotten help with that kept track of how many duplicates a key had and counted them. Now I wish to have it sum the items of each key if there is more than one. Here is what I have that counts items. I have been reading about .exists but don't really know how to use it. Have been messing with this for days to understand it. Hence the debugs. So it is only 2 columns that I need. Column 1 will be the key, column 2 the amount. I want to be able to have amount totals for each key. Obviously I don't know what I am doing. Thank you.
'''code'''

Public Sub TwoColumns()

Dim i As Long, j As Long, w As Long
Dim arr As Variant, dict As Object
Dim WS_Count As Integer
Dim rowString As String

Set dict = CreateObject("scripting.dictionary")
dict.comparemode = vbTextCompare

WS_Count = ActiveWorkbook.Worksheets.Count
rowString = ""

For w = 1 To WS_Count
    With Worksheets(w)

arr = .Range(.Cells(2, "C"), .Cells(.Rows.Count, "D").End(xlUp)).Value2
Debug.Print arr(1, 1) ' 23.1 which is C2
dict.RemoveAll

For i = LBound(arr, 1) To UBound(arr, 1)
    rowString = arr(i, 1)
    Debug.Print "rowString = " & rowString
    Debug.Print "i =" & i & " j = " & j ' i = 1 j =0
    For j = LBound(arr, 2) To UBound(arr, 2) ' assigns 1 to j??
     Debug.Print "arr(i,j)" & arr(i, j) ' 23.1 which is C2
    Debug.Print "2nd.For  i =" & i & " j = " & j
    
    
        dict.Item(arr(i, j)) = dict.Item(arr(i, j))   1
        Debug.Print "arr(i,j)" & arr(i, j)
    Next j
    
Next i

'return new values to worksheet
.Cells(1, "W").Resize(1, 2) = Array("%of Fund", "RBF525")
.Cells(2, "W").Resize(dict.Count, 1) = Application.Transpose(dict.Keys)
.Cells(2, "X").Resize(dict.Count, 1) = Application.Transpose(dict.items)
With .Range(.Cells(1, "W"), .Cells(.Rows.Count, "X").End(xlUp))
    .Sort key1:=Columns(2), order1:=xlDescending, _
          key2:=Columns(1), order2:=xlAscending, _
          Header:=xlYes

End With
End With

Next w

End Sub

CodePudding user response：

See below - you don't need the j loop here

Public Sub TwoColumns()

Dim i As Long, j As Long, w As Long, k, amt
Dim arr As Variant, dict As Object
Dim WS_Count As Long
Dim wb As Workbook

Set dict = CreateObject("scripting.dictionary")
dict.comparemode = vbTextCompare

Set wb = ActiveWorkbook 
WS_Count = wb.Worksheets.Count


For w = 1 To WS_Count
    With wb.Worksheets(w)
        arr = .Range(.Cells(2, "C"), .Cells(.Rows.Count, "D").End(xlUp)).Value2
        Debug.Print arr(1, 1) ' 23.1 which is C2
        dict.RemoveAll

        For i = LBound(arr, 1) To UBound(arr, 1)
            k = arr(i, 1)               'the key
            amt = arr(i, 2)             'the amount
            dict(k) = dict(k)   amt     'sum amount for this key
        Next i

        'return new values to worksheet
        .Cells(1, "W").Resize(1, 2) = Array("%of Fund", "RBF525")
        .Cells(2, "W").Resize(dict.Count, 1) = Application.Transpose(dict.Keys)
        .Cells(2, "X").Resize(dict.Count, 1) = Application.Transpose(dict.items)
        With .Range(.Cells(1, "W"), .Cells(.Rows.Count, "X").End(xlUp))
              .Sort key1:=.Columns(2), order1:=xlDescending, _
                    key2:=.Columns(1), order2:=xlAscending, _
                    Header:=xlYes

        End With
    End With

Next w

CodePudding user response：

Create Unique Sum-Up Tables

This is how it could look like with the help of a few functions.

Option Explicit

Sub CreateUniqueSumUpTables()
    Const ProcName As String = "CreateUniqueSumUpTables"
    On Error GoTo ClearError
    
    Const sfRowRangeAddress As String = "C2:D2"
    Const dfCellAddress As String = "W1"
    Dim Headers As Variant: Headers = VBA.Array("%of Fund", "RBF525")
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim ws As Worksheet
    
    Dim srg As Range ' Source Range
    Dim sfrrg As Range ' Source First Row (Data) Range
    
    Dim dict As Object
    Dim drg As Range ' Destination Range
    Dim dfrrg As Range ' Destination First Row (Header) Range
    Dim ddrg As Range ' Destination Data Range
    Dim Data As Variant ' Source/Destination Array
    
    For Each ws In wb.Worksheets
        Set sfrrg = ws.Range(sfRowRangeAddress)
        Set srg = RefColumns(sfrrg)
        If Not srg Is Nothing Then
            Data = GetRange(srg)
            Set dict = DictArraySum(Data, 1, 2)
            If Not dict Is Nothing Then
                Data = GetDict(dict)
                Set dfrrg = ws.Range(dfCellAddress).Resize(1, 2)
                dfrrg.Value = Headers
                Set drg = dfrrg.Resize(UBound(Data, 1)   1)
                Set ddrg = dfrrg.Resize(UBound(Data, 1)).Offset(1)
                ddrg.Value = Data
                drg.Sort Key1:=drg.Columns(2), Order1:=xlDescending, _
                     Key2:=drg.Columns(1), Order2:=xlAscending, Header:=xlYes
            End If
        End If
    Next ws
 
    MsgBox "Unique sum-up tables created.", vbInformation

ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "' Rte '" & Err.Number & "':" & vbLf _
        & "    " & Err.Description
    Resume ProcExit
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to the range from the first row of a range
'               ('FirstRowRange') to the row range containing
'               the bottom-most non-empty cell in the row's columns.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumns( _
    ByVal FirstRowRange As Range) _
As Range
    If FirstRowRange Is Nothing Then Exit Function
    
    With FirstRowRange.Rows(1)
        Dim lCell As Range
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row   1) _
            .Find("*", , xlFormulas, , xlByRows, xlPrevious)
        If lCell Is Nothing Then Exit Function ' empty range
        Set RefColumns = .Resize(lCell.Row - .Row   1)
    End With

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the values of a range ('rg') in a 2D one-based array.
' Remarks:      If ˙rg` refers to a multi-range, only its first area
'               is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
    ByVal rg As Range) _
As Variant
    If rg Is Nothing Then Exit Function
    
    If rg.Rows.Count   rg.Columns.Count = 2 Then ' one cell
        Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
        GetRange = Data
    Else ' multiple cells
        GetRange = rg.Value
    End If

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the unique values from a column of a 2D array
'               in the keys, and returns the corresponding sum of the values
'               from another column of the array in the items of a dictionary.
' Remarks:      Error values and blanks are excluded.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function DictArraySum( _
    ByVal sData As Variant, _
    ByVal sKeyColumnIndex As Long, _
    ByVal sItemColumnIndex As Long, _
    Optional ByVal DoExcludeNotNumeric As Boolean = False, _
    Optional ByVal DoExcludeZeros As Boolean = False) _
As Object
    Const ProcName As String = "DictArraySum"
    On Error GoTo ClearError

    Dim dDict As Object: Set dDict = CreateObject("Scripting.Dictionary")
    dDict.CompareMode = vbTextCompare
    
    Dim sKey As Variant
    Dim sItem As Variant
    Dim sr As Long
    Dim DoNotSumUp As Boolean
    
    For sr = LBound(sData) To UBound(sData)
        sKey = sData(sr, sKeyColumnIndex)
        If Not IsError(sKey) Then
            If Len(CStr(sKey)) > 0 Then
                sItem = sData(sr, sItemColumnIndex)
                If IsNumeric(sItem) Then
                    If DoExcludeZeros Then
                        If sItem = 0 Then
                            DoNotSumUp = True
                        End If
                    End If
                    If DoNotSumUp Then
                        DoNotSumUp = False
                    Else
                        dDict(sKey) = dDict(sKey)   sItem
                    End If
                Else
                    If Not DoExcludeNotNumeric Then
                        If Not DoExcludeZeros Then
                            dDict(sKey) = dDict(sKey)   0
                        End If
                    End If
                End If
            End If
        End If
    Next sr
    If dDict.Count = 0 Then Exit Function
    
    Set DictArraySum = dDict

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Rte '" & Err.Number & "':" & vbLf _
        & "    " & Err.Description
    Resume ProcExit
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the values from a dictionary in a 2D one-based array.
' Remarks:      F, F, F - returns the keys and items in two columns.
'               F, F, T - returns the items and keys in two columns.
'               F, T, F - returns the keys in a column.
'               F, T, T - returns the items in a column.
'               T, F, F - returns the keys and items in two rows.
'               T, F, T - returns the items and keys in two rows.
'               T, T, F - returns the keys in a row.
'               T, T, T - returns the items in a row.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetDict( _
    ByVal sDict As Object, _
    Optional ByVal Horizontal As Boolean = False, _
    Optional ByVal FirstOnly As Boolean = False, _
    Optional ByVal Flip As Boolean = False) _
As Variant
    Const ProcName As String = "GetDict"
    On Error GoTo ClearError

    Dim sCount As Long: sCount = sDict.Count
    If sCount = 0 Then Exit Function
    
    Dim Data As Variant
    Dim Key As Variant
    Dim i As Long
    
    If Not Horizontal Then
        If Not FirstOnly Then
            ReDim Data(1 To sCount, 1 To 2)
            If Not Flip Then
                For Each Key In sDict.Keys
                    i = i   1
                    Data(i, 1) = Key
                    Data(i, 2) = sDict(Key)
                Next Key
            Else
                For Each Key In sDict.Keys
                    i = i   1
                    Data(i, 1) = sDict(Key)
                    Data(i, 2) = Key
                Next Key
            End If
        Else
            ReDim Data(1 To sCount, 1 To 1)
            If Not Flip Then
                For Each Key In sDict.Keys
                    i = i   1
                    Data(i, 1) = Key
                Next Key
            Else
                For Each Key In sDict.Keys
                    i = i   1
                    Data(i, 1) = sDict(Key)
                Next Key
            End If
        End If
    Else
        If Not FirstOnly Then
            ReDim Data(1 To 2, 1 To sCount)
            If Not Flip Then
                For Each Key In sDict.Keys
                    i = i   1
                    Data(1, i) = Key
                    Data(2, i) = sDict(Key)
                Next Key
            Else
                For Each Key In sDict.Keys
                    i = i   1
                    Data(1, i) = sDict(Key)
                    Data(2, i) = Key
                Next Key
            End If
        Else
            ReDim Data(1 To 1, 1 To sCount)
            If Not Flip Then
                For Each Key In sDict.Keys
                    i = i   1
                    Data(1, i) = Key
                Next Key
            Else
                For Each Key In sDict.Keys
                    i = i   1
                    Data(1, i) = sDict(Key)
                Next Key
            End If
        End If
    End If
    
    GetDict = Data

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Rte '" & Err.Number & "':" & vbLf _
        & "    " & Err.Description
    Resume ProcExit
End Function