excelvba

Create Summary Table with condition in Excel VBA


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. enter image description here

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


Solution

  • 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
    

    enter image description here