Код

Sub SumIfToTarget3() ' Array Dictionary ... 0.2-0.3s

    ' Name
    Const cNsht As Variant = "Sheet2"   ' Name Worksheet Name/Index
    Const cNrow As Long = 1             ' Name First Row Number
    Const cNcol As Long = 3             ' Name Column Number
    Const cVcol As Long = 7             ' Value Column Number
    ' Target
    Const cTsht As Variant = "Sheet2"   ' Target Worksheet Name/Index
    Const cTrow As Long = 1             ' Target First Row Number
    Const cUcol As Long = 8             ' Unique Column Number
    Const cUnique As String = "Unique"  ' Unique Column Header
    Const cSumIf As String = "Total"    ' SumIf Column Header

    ' Create a reference to the Dictionary Object.
    '*******************************************************
    ' Early Binding (0.1s Faster)                          *
    ' You have to go to Tools>References and check (create *
    ' a reference to) "Microsoft Scripting Runtime" .      *
'    Dim dict As New Dictionary '                           *
    '*******************************************************
    '**************************************************
    ' Late Binding (0.1s Slower)                      *
    ' You don't need to create a reference.           *
    Dim dict As Object '                              *
    Set dict = CreateObject("Scripting.Dictionary") ' *
    '**************************************************

    Dim dk As Variant    ' Dictionary 'Counter' (For Each Control Variable)
    Dim CurV As Variant  ' Current Value
    Dim rngN As Range    ' Name Column Range, Last Used Cell in Name Column,
                         ' Name Range with Headers, Name Range
    Dim rngV As Range    ' Value Range
    Dim rngT As Range    ' Target Columns Range, Target Range
    Dim vntN As Variant  ' Name Array
    Dim vntV As Variant  ' Value Array
    Dim vntT As Variant  ' Target Array
    Dim i As Long        ' Name/Value Array Element (Row) Counter,
                         ' Target Array Row Counter, Target Array Rows Count
                         ' (Dictionary Items Count)

    ' Speed up.
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    ' Handle Errors.
    On Error GoTo ErrorHandler

    ' In Unique Column
    With ThisWorkbook.Worksheets(cTsht).Columns(cUcol)
        ' Create a reference to Target Columns Range (rngT) i.e. the range in
        ' Unique Column (cUcol) from Target First Row (cTrow) to the bottom row
        ' of Target Worksheet (cTsht), resized by a column for SumIf Column (2).
        Set rngT = .Resize(.Rows.Count - cTrow + 1, 2).Offset(cTrow - 1)
    End With
    ' Clear contents of Target Columns Range (rngT).
    rngT.ClearContents
    ' Write Unique Column Header to 1st Cell of Target Columns Range.
    rngT.Cells(1) = cUnique
    ' Write SumIf Column Header to 2nd Cell of Target Columns Range.
    rngT.Cells(2) = cSumIf

    ' In Name Column
    With ThisWorkbook.Worksheets(cNsht).Columns(cNcol)
        ' Calculate Last Used Cell in Name Column.
        Set rngN = .find("*", , xlFormulas, , xlByColumns, xlPrevious)
        ' Calculate Name Range with headers.
        Set rngN = .Cells(cNrow).Resize(rngN.Row - cNrow + 1)
    End With
    ' Calculate Name Range (without headers).
    Set rngN = rngN.Resize(rngN.Rows.Count - 1).Offset(1)
    ' Copy Name Range (rngN) to Name Array (vntN).
    vntN = rngN
    ' Calculate Value Range (without headers).
    Set rngV = rngN.Offset(, cVcol - cNcol)
    ' Copy Value Range (rngV) to Value Array (vntV).
    vntV = rngV

    ' Loop through elements (rows) of Name Array.
    For i = 1 To UBound(vntN)
        ' Write element in current row (i) of Value Array (vntV) to Current
        ' Value.
        CurV = vntV(i, 1)
        ' Check if Current Value (CurV) is NOT a number.
        If Not IsNumeric(CurV) Then
            ' Assign 0 to Current Value.
            CurV = 0
        End If
        ' Add current element (row) in Name Array (vntN) and Current Value
        ' to the Dictionary. If the key to be added is new (not existing),
        ' the new key and the item will be added. But if the key exists, then
        ' the existing item will be increased by the value of the new item.
        ' This could be called "The Dictionary SumIf Feature".
        dict(vntN(i, 1)) = dict(vntN(i, 1)) + CurV
    Next

    ' Reset Name/Value Array Element (Row) Counter to be used as
    ' Target Array Row Counter.
    i = 0
    ' Resize Target Array to the number of items in the Dictionary.
    ReDim vntT(1 To dict.Count, 1 To 2)
    ' Loop through each Key (Item) in the Dictionary.
    For Each dk In dict.Keys
        ' Increase Target Array Row Counter (count Target Array Row).
        i = i + 1
        ' Write current Dictionary Key to element in current (row) and
        ' 1st column (Unique) of Target Array.
        vntT(i, 1) = dk
        ' Write current Dictionary Item to element in current (row) and
        ' 2nd column (SumIf) of Target Array.
        vntT(i, 2) = dict(dk)
    Next

    ' Calculate Target Range (rngT) from second row (2) of Target Columns
    ' Range (rngT) resized by Target Array Rows Count (i).
    Set rngT = rngT.Rows(2).Resize(i)
    ' Copy Target Array (vntT) to Target Range (rngT).
    rngT = vntT

ProcedureExit:

    ' Speed down.
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

Exit Sub

ErrorHandler:

    MsgBox "An unexpected error occurred. Error '" & Err.Number & "': " _
            & Err.Description, vbCritical, "Error"
    GoTo ProcedureExit

End Sub

SUMIF ?! Решение Excel

Это больше вопрос, чем ответ:

Можно ли это рассматривать как упрощенную визуальную презентацию того, чего вы пытаетесь достичь?

Вы можете использовать следующую формулу в ячейке I2:

=SUMIF(C$2:C$16,H2,G$2:G$16)

Отрегулируйте диапазоны и скопируйте вниз.

Усовершенствованное решение для фильтрации фильтрующего цикла

Sub SumIfToUnique2() ' Advanced Filter & Loop through Arrays, Add ... 13s

    ' Name
    Const cNsht As Variant = "Sheet2"   ' Name Worksheet Name/Index
    Const cNrow As Long = 1             ' Name First Row Number
    Const cNcol As Long = 3             ' Name Column Number
    Const cVcol As Long = 7             ' Value Column Number
    ' Unique
    Const cUsht As Variant = "Sheet2"   ' Unique Worksheet Name/Index
    Const cUrow As Long = 1             ' Unique First Row Number
    Const cUcol As Long = 8             ' Unique Column Number
    Const cSumIf As String = "Total"    ' SumIf Column Header
    Const cUnique As String = "Unique"  ' Unique Column Header

    Dim rngN As Range    ' Name Column Range, Last Used Cell in Name Column,
                         ' Name Range with Headers, Name Range
    Dim rngV As Range    ' Value Range
    Dim rngU As Range    ' Unique Column Range, Last Used Cell in Unique Column,
                         ' Unique Range
    Dim vntN As Variant  ' Name Array
    Dim vntV As Variant  ' Value Array
    Dim vntU As Variant  ' Unique Array
    Dim vntS As Variant  ' SumIf Array
    Dim i As Long        ' Name/Value Array Row Counter
    Dim k As Long        ' Unique/SumIf Array Row Counter
    Dim strN As String   ' Current Name (in Name Array)

    ' Speed up.
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    ' Handle Errors.
    On Error GoTo ErrorHandler

    ' In Name Column
    With ThisWorkbook.Worksheets(cNsht).Columns(cNcol)
        ' Create a reference to Name Column Range (rngN) i.e. the range in
        ' Name Column (cNcol) from Name First Row (cNrow) to the bottom row
        ' of Name Worksheet (cNsht).
        Set rngN = .Resize(.Rows.Count - cNrow + 1).Offset(cNrow - 1)
    End With

    ' In Unique Column
    With ThisWorkbook.Worksheets(cUsht).Columns(cUcol)
        ' Create a reference to Unique Column Range (rngU) i.e. the range in
        ' Unique Column (cUcol) from Unique First Row (cUrow) to the bottom row
        ' of Unique Worksheet (cUsht).
        Set rngU = .Resize(.Rows.Count - cUrow + 1).Offset(cUrow - 1)
    End With
    ' Clear contents of Unique Column Range (rngU).
    rngU.ClearContents
    ' Calculate SumIf Column Range.
    ' Clear contents of SumIf Column Range.
    rngU.Offset(, 1).ClearContents

    ' Write unique values from Name Column Range (rngN), starting with the
    ' header (aka title), to Unique Column Range (rngU), starting in its
    ' First Row (1).
    rngN.AdvancedFilter xlFilterCopy, , rngU.Resize(1), True
    ' Calculate Unique Header Cell Range.
    ' Write Unique Column Header to Unique Header Cell Range.
    rngU.Resize(1) = cUnique
    ' Calculate SumIf Header Cell Range.
    ' Write SumIf Column Header to SumIf Header Cell Range.
    rngU.Resize(1).Offset(, 1) = cSumIf

    ' In Name Column
    With ThisWorkbook.Worksheets(cNsht).Columns(cNcol)
        ' Calculate Last Used Cell in Name Column.
        Set rngN = .find("*", , xlFormulas, , xlByColumns, xlPrevious)
        ' Calculate Name Range with headers.
        Set rngN = .Cells(cNrow).Resize(rngN.Row - cNrow + 1)
    End With
    ' Calculate Name Range (without headers).
    Set rngN = rngN.Resize(rngN.Rows.Count - 1).Offset(1)
    ' Copy Name Range (rngN) to Name Array (vntN).
    vntN = rngN
    ' Calculate Value Range (without headers).
    Set rngV = rngN.Offset(, cVcol - cNcol)
    ' Copy Value Range (rngV) to Value Array (vntV).
    vntV = rngV

    ' In Unique Column
    With ThisWorkbook.Worksheets(cUsht).Columns(cUcol)
        ' Calculate Last Used Cell in Unique Column.
        Set rngU = .find("*", , xlFormulas, , xlByColumns, xlPrevious)
        ' Calculate Unique Range with headers.
        Set rngU = .Cells(cUrow).Resize(rngU.Row - cUrow + 1)
    End With
    ' Calculate Unique Range (without headers).
    Set rngU = rngU.Resize(rngU.Rows.Count - 1).Offset(1)
    ' Copy Unique Range (rngU) to Unique Array (vntU).
    vntU = rngU

    ' Resize SumIf Array to size of Unique Array.
    ReDim vntS(1 To UBound(vntU), 1 To 1)
    ' Loop through elements (rows) of Name Array.
    For i = 1 To UBound(vntN)
        ' Write current value in Name Array (vntN) to Current Name (strN).
        strN = vntN(i, 1)
        ' Loop through elements (rows) of Unique/SumIf Array.
        For k = 1 To UBound(vntU)
            If vntU(k, 1) = strN Then
                vntS(k, 1) = vntS(k, 1) + vntV(i, 1)
                Exit For
            End If
        Next
    Next

    ' Calculate SumIf Range (from Unique Range (rngU)).
    ' Copy SumIf Array to SumIf Range.
    rngU.Offset(, 1) = vntS

ProcedureExit:

    ' Speed down.
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

Exit Sub

ErrorHandler:

    MsgBox "An unexpected error occurred. Error '" & Err.Number & "': " _
            & Err.Description, vbCritical, "Error"
    GoTo ProcedureExit

End Sub

Sub SumIfToUnique1() ' Advanced Filter & SumIf on Ranges ... 17-22s

    ' Name
    Const cNsht As Variant = "Sheet2"   ' Name Worksheet Name/Index
    Const cNrow As Long = 1             ' Name First Row Number
    Const cNcol As Long = 3             ' Name Column Number
    Const cVcol As Long = 7             ' Value Column Number
    ' Unique
    Const cUsht As Variant = "Sheet2"   ' Unique Worksheet Name/Index
    Const cUrow As Long = 1             ' Unique First Row Number
    Const cUcol As Long = 8             ' Unique Column Number
    Const cSumIf As String = "Total"    ' SumIf Column Header
    Const cUnique As String = "Unique"  ' Unique Column Header

    Dim rngN As Range    ' Name Column Range, Last Used Cell in Name Column,
                         ' Name Range with Headers, Name Range
    Dim rngV As Range    ' Value Range
    Dim rngU As Range    ' Unique Column Range, Last Used Cell in Unique Column,
                         ' Unique Range
    Dim vntU As Variant  ' Unique Array
    Dim vntS As Variant  ' SumIf Array
    Dim i As Long        ' Unique Array Row Counter

    ' Speed up.
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    ' Handle Errors.
    On Error GoTo ErrorHandler

    ' In Name Column
    With ThisWorkbook.Worksheets(cNsht).Columns(cNcol)
        ' Create a reference to Name Column Range (rngN) i.e. the range in
        ' Name Column (cNcol) from Name First Row (cNrow) to the bottom row
        ' of Name Worksheet (cNsht).
        Set rngN = .Resize(.Rows.Count - cNrow + 1).Offset(cNrow - 1)
    End With

    ' In Unique Column
    With ThisWorkbook.Worksheets(cUsht).Columns(cUcol)
        ' Create a reference to Unique Column Range (rngU) i.e. the range in
        ' Unique Column (cUcol) from Unique First Row (cUrow) to the bottom row
        ' of Unique Worksheet (cUsht).
        Set rngU = .Resize(.Rows.Count - cUrow + 1).Offset(cUrow - 1)
    End With
    ' Clear contents of Unique Column Range (rngU).
    rngU.ClearContents
    ' Calculate SumIf Column Range.
    ' Clear contents of SumIf Column Range.
    rngU.Offset(, 1).ClearContents

    ' Write unique values from Name Column Range (rngN), starting with the
    ' header (aka title), to Unique Column Range (rngU), starting in its
    ' First Row (1).
    rngN.AdvancedFilter xlFilterCopy, , rngU.Resize(1), True
    ' Calculate Unique Header Cell Range.
    ' Write Unique Column Header to Unique Header Cell Range.
    rngU.Resize(1) = cUnique
    ' Calculate SumIf Header Cell Range.
    ' Write SumIf Column Header to SumIf Header Cell Range.
    rngU.Resize(1).Offset(, 1) = cSumIf

    ' In Name Column
    With ThisWorkbook.Worksheets(cNsht).Columns(cNcol)
        ' Calculate Last Used Cell in Name Column.
        Set rngN = .find("*", , xlFormulas, , xlByColumns, xlPrevious)
        ' Calculate Name Range with headers.
        Set rngN = .Cells(cNrow).Resize(rngN.Row - cNrow + 1)
    End With
    ' Calculate Name Range (without headers).
    Set rngN = rngN.Resize(rngN.Rows.Count - 1).Offset(1)
    ' Calculate Value Range (without headers).
    Set rngV = rngN.Offset(, cVcol - cNcol)

    ' In Unique Column
    With ThisWorkbook.Worksheets(cUsht).Columns(cUcol)
        ' Calculate Last Used Cell in Unique Column.
        Set rngU = .find("*", , xlFormulas, , xlByColumns, xlPrevious)
        ' Calculate Unique Range with headers.
        Set rngU = .Cells(cUrow).Resize(rngU.Row - cUrow + 1)
    End With
    ' Calculate Unique Range (without headers).
    Set rngU = rngU.Resize(rngU.Rows.Count - 1).Offset(1)
    ' Copy Unique Range to Unique Array.
    vntU = rngU

    ' Resize SumIf Array to size of Unique Array.
    ReDim vntS(1 To UBound(vntU), 1 To 1)

    ' Loop through elements (rows) of SumIf/Unique Array.
    For i = 1 To UBound(vntS)
        ' Write result of SumIf funtion to current element (row) of SumIf Array.
        vntS(i, 1) = WorksheetFunction.SumIf(rngN, vntU(i, 1), rngV)
    Next

    ' Calculate SumIf Range (from Unique Range (rngU)).
    ' Copy SumIf Array to SumIf Range.
    rngU.Offset(, 1) = vntS

ProcedureExit:

    ' Speed down.
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

Exit Sub

ErrorHandler:

    MsgBox "An unexpected error occurred. Error '" & Err.Number & "': " _
            & Err.Description, vbCritical, "Error"
    GoTo ProcedureExit

End Sub