Home VBA loop to show summary without pivot table
Reply: 1

VBA loop to show summary without pivot table

Brandon Jake Sullano
Brandon Jake Sullano Published in 2017-12-07 12:12:55Z

I am having problem in crating a loop to have summary on my table data. To make my question clear refer to below image.

Thank you in advance.

Tom Reply to 2017-12-07 16:48:21Z

This is probably massively overkill but will be quick if you've got a large data set that you're working on (which I'm guessing you are otherwise you could do this easily by hand or using a pivot table). Please have a look at the comments and update where stated. It will currently output to cell E2 on the activesheet but I recommend updating ActiveSheet to your actual sheet name and E2 to your desired location

Public Sub Example()
    Dim rng As Range
    Dim tmpArr As Variant
    Dim Dict As Object, tmpDict As Object
    Dim i As Long, j As Long
    Dim v, key

    Set Dict = CreateObject("Scripting.Dictionary")

    ' Update to your sheet here
    With ActiveSheet
        ' You may need to modify this depending on where you range is stored
        Set rng = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 2))

        tmpArr = rng.Value

        For i = LBound(tmpArr, 1) To UBound(tmpArr, 1)
            ' Test if value exists in dictionary. If not add and set up the dictionary item
            If Not Dict.exists(tmpArr(i, 1)) Then
                Set tmpDict = Nothing
                Set tmpDict = CreateObject("Scripting.Dictionary")
                Dict.Add key:=tmpArr(i, 1), Item:=tmpDict
            End If
            ' Set nested dictionary to variable so we can edit it
            Set tmpDict = Nothing
            Set tmpDict = Dict(tmpArr(i, 1))

            ' Test if value exists in nested Dictionary, add if not and initiate counter
            If Not tmpDict.exists(tmpArr(i, 2)) Then
                tmpDict.Add key:=tmpArr(i, 2), Item:=1
                ' Increment counter if it already exists
                tmpDict(tmpArr(i, 2)) = tmpDict(tmpArr(i, 2)) + 1
            End If
            ' Write nested Dictionary back to Main dictionary
            Set Dict(tmpArr(i, 1)) = tmpDict
        Next i

        ' Repurpose array for output setting to maximum possible size (helps with speed of code)
        ReDim tmpArr(LBound(tmpArr, 2) To UBound(tmpArr, 2), LBound(tmpArr, 1) To UBound(tmpArr, 1))
        ' Set starting counters for array
        i = LBound(tmpArr, 1)
        j = LBound(tmpArr, 2)
        ' Convert dictionary and nested dictionary to flat output
        For Each key In Dict
            tmpArr(j, i) = key
            i = i + 1
            For Each v In Dict(key)
                tmpArr(j, i) = v
                tmpArr(j + 1, i) = Dict(key)(v)
                i = i + 1
            Next v
        Next key
        ' Reshape array to actual size
        ReDim Preserve tmpArr(LBound(tmpArr, 1) To UBound(tmpArr, 1), LBound(tmpArr, 2) To i - 1)
        ' Change this to the starting cell of your output
        With .Cells(2, 5)
            Range(.Offset(0, 0), .Cells(UBound(tmpArr, 2), UBound(tmpArr, 1))) = Application.Transpose(tmpArr)
        End With
    End With
End Sub
You need to login account before you can post.

About| Privacy statement| Terms of Service| Advertising| Contact us| Help| Sitemap|
Processed in 0.244734 second(s) , Gzip On .

© 2016 Powered by mzan.com design MATCHINFO