如何用VBA实现一次性多列数据分类汇总，类似单列数据透视表

·遁去的一· · 发表于 2023-5-22 15:03

Hontyu 发表于 2023-5-22 11:55
.............

内存溢出，数据仅1万行

吴中泉 · 发表于 2023-5-22 15:53

·遁去的一· 发表于 2023-5-22 15:03
内存溢出，数据仅1万行

编码就用了大半天,看到这么多人都发贴子了,还是来迟了,既来了,还是交作业吧,请测试.

类似数据透视的复杂合并汇总.zip (39.71 KB, 下载次数: 8)

吴中泉 · 发表于 2023-5-22 15:58

代码截图

Hontyu · 发表于 2023-5-22 16:37

.........

·遁去的一· · 发表于 2023-5-22 16:56

Hontyu 发表于 2023-5-22 16:37
.........

100万行数据，内存溢出

grf1973 · 发表于 2023-5-22 16:56

。。。。。。。。。。。。。

·遁去的一· · 发表于 2023-5-22 17:02

经测试，VBA最佳效果代码如下：

Sub cs()
Application.ScreenUpdating = False
Dim arr, brr, dic
Dim i, i2, i3, r, n
Dim key
Dim rg
Set dic = CreateObject("Scripting.Dictionary")
arr = Sheets("数据源").Range("A1").CurrentRegion
For i = 1 To UBound(arr)
If Not dic.exists(arr(i, 1)) Then
Set dic(arr(i, 1)) = CreateObject("Scripting.Dictionary") '创建第1列内容为key的字典
End If
For i2 = 2 To UBound(arr, 2) '从第2列开始分类汇总
If Not dic(arr(i, 1)).exists(arr(1, i2)) Then
'创建第2列开始以标题为key的嵌套字典
Set dic(arr(i, 1))(arr(1, i2)) = CreateObject("Scripting.Dictionary")
End If
dic(arr(i, 1))(arr(1, i2))(arr(i, i2)) = 1 + dic(arr(i, 1))(arr(1, i2))(arr(i, i2))
Next i2
Next i
With Sheets("结果表").Range("A2")
.CurrentRegion.Clear '清除内容
.Resize(dic.Count) = Application.Transpose(dic.keys) '输出第1列数据
For i = 2 To UBound(arr, 2) '循环数据源的列，从第2列开始
key = arr(1, i)
n = .CurrentRegion.Columns.Count '当前已输出数据的列数
.Offset(-1, n).Value = key '输出第1行标题
i2 = 1 '用来循环第1列内容
Do While .Offset(i2).Value <> ""
Set rg = .Offset(i2)
If i2 > 1 Then
brr = .CurrentRegion.Offset(, n)
For i3 = 1 To UBound(brr, 2) - n
'判断第2行的标题是否已输出到表格中
If dic(rg.Value)(key).exists(brr(2, i3)) Then
'将对应的内容输出到表格中
rg.Offset(, n + i3 - 1).Value = dic(rg.Value)(key)(brr(2, i3))
'删除标题对应的键值
dic(rg.Value)(key).Remove brr(2, i3)
End If
Next i3
'判断标题对应的字典个数
If dic(rg.Value)(key).Count >= 1 Then
.Offset(, UBound(brr, 2)).Resize(1, dic(rg.Value)(key).Count) = dic(rg.Value)(key).keys
.Offset(i2, UBound(brr, 2)).Resize(1, dic(rg.Value)(key).Count) = dic(rg.Value)(key).items
End If
Else
.Offset(, n).Resize(1, dic(rg.Value)(key).Count) = dic(rg.Value)(key).keys
.Offset(i2, n).Resize(1, dic(rg.Value)(key).Count) = dic(rg.Value)(key).items
End If
i2 = i2 + 1
Loop
'合并第一行标题的单元格
.Offset(-1, n).Resize(1, .CurrentRegion.Columns.Count - n).Merge
Next i
'合计行
.End(xlDown).Offset(1).Value = "合计"
r = .CurrentRegion.Rows.Count - 3 '求和的行数
key = .Offset(1, 1).Resize(r, 1).Address(0, 0) '合计的单元格地址
.End(xlDown).Offset(, 1).Value = "=sum(" & key & ")" '设置合计公式
r = .CurrentRegion.Columns.Count - 1 '合计的列数
.End(xlDown).Offset(, 1).AutoFill Destination:=.End(xlDown).Offset(, 1).Resize(1, r) '填充公式
.Offset(-1).Resize(2, 1).Merge '合并第1列的标题
.CurrentRegion.Borders.LineStyle = xlContinuous '边框
.CurrentRegion.HorizontalAlignment = xlCenter '字体居中
End With
Application.ScreenUpdating = True
End Sub

复制代码

slonby · 发表于 2023-5-22 17:11

笨鸟飞不高发表于 2023-5-22 12:41
练习！

数据有空的时候，如男选择留空，还是会出问题。

·遁去的一· · 发表于 2023-5-22 21:42

grf1973 发表于 2023-5-22 16:56
。。。。。。。。。。。。。

运行未通过，而且这种方法好像对列的唯一值有限制

吴中泉 · 发表于 2023-5-22 22:19

本帖最后由吴中泉于 2023-5-22 22:20 编辑

·遁去的一· 发表于 2023-5-22 21:42
运行未通过，而且这种方法好像对列的唯一值有限制

修改完善了一下，请测试，可能有惊喜

类似数据透视的复杂合并汇总.rar (31.79 KB, 下载次数: 18)

		自动登录	找回密码
密码			免费注册

[求助] 如何用VBA实现一次性多列数据分类汇总，类似单列数据透视表