VBA循环显示没有数据透视表的摘要

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.

先谢谢你。

1 个解决方案

#1

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

这可能是大规模的过度杀伤,但是如果你有一个大型数据集正在处理它会很快(我猜你是否可以通过手动或使用数据透视表轻松完成)。请查看评论并更新说明。它当前将输出到活动表上的单元格E2,但我建议将ActiveSheet更新为您的实际工作表名称,并将E2更新到您想要的位置

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
            Else
                ' 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