Criar tabela de resumo com condição no Excel VBA

Experimente esta fórmula:

=HSTACK(ROW(INDIRECT("1:"&ROWS(UNIQUE(B4:B10)))),UNIQUE(B4:C10),BYROW(UNIQUE(B4:B10),LAMBDA(art,SUM((B4:B10=art)*D4:D10))))

• O layout da tabela pode ser diferente em sua planilha. Revise o código conforme necessário.

Option Explicit
Sub Demo()
    Dim objDic As Object, rngData As Range
    Dim i As Long, sKey As String, aKey
    Dim arrData, arrRes
    Const QTY_COL = 4
    Set objDic = CreateObject("scripting.dictionary")
    ' Load data
    Set rngData = Range("A1").CurrentRegion
    arrData = rngData.Value
    ' Summarize by Artical Code
    For i = LBound(arrData) + 2 To UBound(arrData)
        sKey = arrData(i, 2)
        If objDic.exists(sKey) Then
            objDic(sKey) = objDic(sKey) + arrData(i, 4)
        Else
            objDic(sKey) = arrData(i, 4)
        End If
    Next i
    ReDim arrRes(1 To objDic.Count, 3)
    aKey = objDic.keys
    ' Populate the summary array
    For i = 1 To objDic.Count
        arrRes(i, 0) = i
        arrRes(i, 1) = aKey(i - 1)
        arrRes(i, 2) = "pcs"
        arrRes(i, 3) = objDic(aKey(i - 1))
    Next
    Dim lastRow As Long
    lastRow = Cells(Rows.Count, "F").End(xlUp).Row
    If lastRow > 2 Then Range("F3:I" & lastRow).Clear
    ' Write output to sheet
    Range("F3").Resize(objDic.Count, 4) = arrRes
    ' modify as needed
    Range("F1").CurrentRegion.Borders.LineStyle = xlContinuous
    Range("F:I").HorizontalAlignment = xlCenter
End Sub