T3705_Account Statement Unique Totals Arrays Dictionary

https://excel-egy.com/forum/t3705
---------------------------------

Sub Account_Statement_Unique_Totals_Arrays_Dictionary()
    Dim ws          As Worksheet
    Dim sh          As Worksheet
    Dim dic         As Object
    Dim a           As Variant
    Dim b           As Variant
    Dim s           As String
    Dim i           As Long
    Dim j           As Long
    Dim k           As Long

    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets("Data")
        Set sh = ThisWorkbook.Worksheets("Report")
        Set dic = CreateObject("Scripting.Dictionary")
        a = ws.Range("B3").CurrentRegion.Value
        ReDim b(1 To UBound(a), 1 To 6)

        For i = 2 To UBound(a)
            If a(i, 5) = IIf(sh.Range("F2").Value = "", a(i, 5), sh.Range("F2").Value) Then
                s = a(i, 1) & Chr(2) & a(i, 5)
                If Not dic.Exists(s) Then
                    k = k + 1
                    dic.Add s, k
                    For j = 1 To 5
                        b(k, j) = a(i, j)
                    Next j
                    b(k, 6) = a(i, 7)
                Else
                    b(dic(s), 6) = b(dic(s), 6) + a(i, 7)
                End If
            End If
        Next i

        sh.Range("B4").CurrentRegion.Offset(1).ClearContents
        sh.Range("B5").Resize(k, UBound(b, 2)).Value = b
    Application.ScreenUpdating = True
End Sub