Derive sum of amounts based on the unique currency code from the table

[inddon]

Hello There,

I have an excel table with a column currency code. I would like to have a VBA code which can list out all the unique currency codes from the table and list the total amount against the currency code.

The number of rows of this table is flexible and is managed by another process, which includes deletion and addition of rows. Therefore, this summary of currency amounts needs to be displayed at the end of the table.


Attached is a sample workbook for your reference.

Could you please advise how this could be achieved using VBA?

Thanks & regards,
Don

 

[Chihiro]

Something like below. Adjust as needed.

Sub UniqueSum()
Dim ccodeDict As Object
Dim tbl As ListObject
Dim cel As Range, rRange As Range
Dim rRow As Integer

Set ccodeDict = CreateObject("Scripting.Dictionary")
Set tbl = Worksheets("Sheet1").ListObjects("Table1")

With ccodeDict
    .CompareMode = vbTextCompare
    For Each cel In tbl.DataBodyRange.Columns(3).Cells
        If .exists(cel.Value) Then
            .Item(cel.Value) = .Item(cel.Value) + cel.Offset(, 1).Value
        Else
            .Add cel.Value, cel.Offset(, 1).Value
        End If
    Next cel

    rRow = tbl.Range.End(xlDown).Row + 3

    Set rRange = Cells(rRow, 7)
    rRange.Resize(.Count).Value = Application.Transpose(.Keys)
    rRange.Offset(, 1).Resize(.Count).Value = Application.Transpose(.items)
End With

End Sub

 

[Marc L]

Hi Chihiro !

A mod of your code (lines #13 to 17) :​

'        If .exists(cel.Value) Then
            .Item(cel.Value) = .Item(cel.Value) + cel.Offset(, 1).Value
'        Else
'            .Add cel.Value, cel.Offset(, 1).Value
'        End If

You just need codeline #14 as written in Dictionary Item help …​

Beginner's way : an advanced filter to list unique currencies
and even in VBA same easy Excel formula to sum amounts !
​

 

[Chihiro]

Thanks Marc. Huh, never knew that you can add item in that manner.

 

[inddon]

Something like below. Adjust as needed.

Sub UniqueSum()
Dim ccodeDict As Object
Dim tbl As ListObject
Dim cel As Range, rRange As Range
Dim rRow As Integer

Set ccodeDict = CreateObject("Scripting.Dictionary")
Set tbl = Worksheets("Sheet1").ListObjects("Table1")

With ccodeDict
    .CompareMode = vbTextCompare
    For Each cel In tbl.DataBodyRange.Columns(3).Cells
        If .exists(cel.Value) Then
            .Item(cel.Value) = .Item(cel.Value) + cel.Offset(, 1).Value
        Else
            .Add cel.Value, cel.Offset(, 1).Value
        End If
    Next cel

    rRow = tbl.Range.End(xlDown).Row + 3

    Set rRange = Cells(rRow, 7)
    rRange.Resize(.Count).Value = Application.Transpose(.Keys)
    rRange.Offset(, 1).Resize(.Count).Value = Application.Transpose(.items)
End With

End Sub

Thanks Chihiro and Marc.

In the table, the Amount column has a conditional currency format:
1. To get the currency sign based on the currency code

Also, the number format.

How can this be added in the code?


Regards,
Don

 

[Chihiro]

How many currency type do you have? If much larger number of currency type is present in actual data, I'd suggest using LookUp table. Otherwise, if the list is small enough (like in sample), you can just use Case statement to set NumberFormat.

 

[inddon]

How many currency type do you have? If much larger number of currency type is present in actual data, I'd suggest using LookUp table. Otherwise, if the list is small enough (like in sample), you can just use Case statement to set NumberFormat.

Hi Chihiro,

At the max it should be 3 currency types.


Regards,
Don

 

[Chihiro]

Changed the code a bit. Instead of transpose, loop through Key to check and set format.

Sub UniqueSum()
Dim ccodeDict As Object
Dim tbl As ListObject
Dim cel As Range, rRange As Range
Dim rRow As Integer
Dim key As Variant, i As Integer

Set ccodeDict = CreateObject("Scripting.Dictionary")
Set tbl = Worksheets("Sheet1").ListObjects("Table1")

With ccodeDict
    .CompareMode = vbTextCompare
    For Each cel In tbl.DataBodyRange.Columns(3).Cells
            .Item(cel.Value) = .Item(cel.Value) + cel.Offset(, 1).Value
    Next cel

    rRow = tbl.Range.End(xlDown).Row + 3

    Set rRange = Cells(rRow, 7)
    i = 1
    For Each key In .Keys
        rRange(i, 1).Value = key
        rRange(i, 2).Value = .Item(key)
        With rRange(i, 2)
        Select Case key
            Case Is = "EUR"
                .NumberFormat = "€##,###"
            Case Is = "USD"
                .NumberFormat = "$##,###"
            Case Is = "GBP"
                .NumberFormat = "£##,###"
        End Select
        End With
        i = i + 1
    Next key
End With

End Sub

 

[inddon]

Changed the code a bit. Instead of transpose, loop through Key to check and set format.

Thanks Chihiro for you support

Regards,
Don