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

我在创build一个循环有我的表数据摘要的问题。 为了使我的问题清楚地参考下面的图像。

先谢谢你。

Answer 1

这可能是大规模的矫枉过正，但如果你有一个大的数据集，你正在工作（我猜你是否可以用手或使用数据透视表很容易）。 请看看评论和更新的地方。 它当前将输出到单元格E2 ，但我build议将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