Create Summary Table with condition in Excel VBA

Question

I'm trying to create a summary table using VBA in Excel app.

To achieve this I will reduce the lines with the same ARTICLE CODE into a single line. I have shared a picture below for easier understanding.

I tried to solve it by creating an array, but it was a very long code and I couldn't solve it.

Answer 1

• The table layout may be different on your sheet, please revise the code as needed.

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