模拟透视模式统计数据表

qlmgu

各位老师早上好。

在多位老师帮助下解决了考核中的难题。现在对数据统计初期过程进行优化，简化大量的手工透视步骤。下面是数据和需求。有什么没说明白或不对的地方，请老师指出。再次感谢各位老师。


数据源说明：
1.A-E列为统计对象分类，主要是各种名称； 2.F-O列为各项统计指标，有数值型和文本型数据(只选了部分代表数据，实际数据还多些）；
统计项目填写区：P-R列为统计选择项填写区；行、列和值的概念是参考透视表的功能；


实际统计结果：我用手工透视的方法，对全部数据进行了统计，作为编程参考。见参考结果页；


希望得到的结果: 放在统计结果页；


模拟数据： 模拟数据和结果.rar (282.08 KB, 下载次数: 13)

2024-2-21 07:43 上传

点击文件名下载附件

ykcbf1100

先标记一下

qlmgu

ykcbf1100 发表于 2024-2-21 08:05
先标记一下

ykcbf1100老师早上好。谢谢您关注

ykcbf1100

就是一个系统工程，太费时间了，终于完成了。
代码更新一下，加入合计行。

ykcbf1100

代码更新一下。

1. Sub ykcbf()   '//2024.2.21
   
2.     Dim arr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set d1 = CreateObject("Scripting.Dictionary")
   
6.     Set d2 = CreateObject("Scripting.Dictionary")
   
7.     With Sheets("数据源")
   
8.         r = .Cells(.Rows.Count, "a").End(xlUp).Row
   
9.         arr = .[a1].Resize(r, 12)
   
10.     End With
    
11.     b = [{7,10,12}]
    
12.     For i = 2 To UBound(arr)
    
13.         s = arr(i, 4)
    
14.         For j = 8 To 9
    
15.             s1 = s & "|" & arr(1, j)
    
16.             If Not d1.exists(s1) Then
    
17.                 d1(s1) = Array(arr(i, j), arr(i, j), arr(i, j), 1)
    
18.             Else
    
19.                 t = d1(s1)
    
20.                 t(0) = t(0) + arr(i, j)
    
21.                 t(1) = IIf(t(1) < arr(i, j), arr(i, j), t(1))
    
22.                 t(2) = IIf(t(2) > arr(i, j), arr(i, j), t(2))
    
23.                 t(3) = t(3) + 1
    
24.                 d1(s1) = t
    
25.             End If
    
26.         Next
    
27.         s2 = arr(i, 4) & "|" & arr(i, 11)
    
28.         d2(s2) = d2(s2) + 1
    
29.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
30.         For j = 1 To UBound(b)
    
31.             ss = arr(i, b(j))
    
32.             d(s)(ss) = d(s)(ss) + 1
    
33.         Next
    
34.     Next
    
35.     ReDim zrr(1 To d.Count, 1 To 2)
    
36.     For Each k In d.keys
    
37.         m = m + 1
    
38.         zrr(m, 1) = k
    
39.         zrr(m, 2) = Val(Replace(k, "单位", ""))
    
40.     Next
    
41.     On Error Resume Next
    
42.     With Sheets("统计结果")
    
43.         .UsedRange.Offset(1).Clear
    
44.         .[a2].Resize(m, 2) = zrr
    
45.         .[a2].Resize(m, 2).Sort .[b2], 1
    
46.         arr = .UsedRange
    
47.         For i = 2 To UBound(arr)
    
48.             If arr(i, 1) <> Empty Then
    
49.                 For j = 2 To 6
    
50.                     s = arr(i, 1)
    
51.                     If d.exists(s) Then
    
52.                         arr(i, j) = d(s)(arr(1, j))
    
53.                     End If
    
54.                 Next
    
55.                 For j = 7 To 10
    
56.                     s = arr(i, 1)
    
57.                     ss = Replace(Replace(arr(1, j), "评价类型-", ""), "个数", "")
    
58.                     If d.exists(s) Then
    
59.                         arr(i, j) = d(s)(ss)
    
60.                     End If
    
61.                 Next
    
62.                 For j = 19 To 23
    
63.                     s = arr(i, 1)
    
64.                     ss = Replace(Replace(arr(1, j), "数字范围", ""), "个数", "")
    
65.                     If d.exists(s) Then
    
66.                         arr(i, j) = d(s)(ss)
    
67.                     End If
    
68.                 Next
    
69.                 t = d1(arr(i, 1) & "|" & "时差")
    
70.                 arr(i, 11) = Format(t(0) / t(3), "0.00")
    
71.                 arr(i, 12) = Format(t(1), "0.00")
    
72.                 arr(i, 13) = Format(t(2), "0.00")
    
73.                 arr(i, 24) = t(3)
    
74.                 t = d1(arr(i, 1) & "|" & "文本字数")
    
75.                 arr(i, 14) = Format(t(0) / t(3), "0.00")
    
76.                 arr(i, 15) = Format(t(1), "0.00")
    
77.                 arr(i, 16) = Format(t(2), "0.00")
    
78.                 arr(i, 17) = d2(arr(i, 1) & "|" & "达标")
    
79.                 arr(i, 18) = d2(arr(i, 1) & "|" & "不达标")
    
80.             End If
    
81.         Next
    
82.         .UsedRange = arr
    
83.         .UsedRange.Borders.LineStyle = 1
    
84.         r = .Cells(Rows.Count, 1).End(3).Row
    
85.         .Cells(r + 1, 1) = "总计"
    
86.         .Cells(r + 1, 2).Resize(1, 23).FormulaR1C1 = "=SUM(R2C:R" & "[-1]C)"
    
87.         .UsedRange.Offset(r + 1).Clear
    
88.     End With
    
89.     Set d = Nothing
    
90.     Application.ScreenUpdating = True
    
91.     MsgBox "OK！"
    
92. End Sub
    

复制代码

fzxba

改一下规范一点.zip (303.36 KB, 下载次数: 22)

2024-2-21 13:47 上传

点击文件名下载附件

yynrzwh

模拟数据和结果.rar (295.7 KB, 下载次数: 18)

2024-2-21 10:35 上传

点击文件名下载附件

qlmgu

ykcbf1100老师，fzxba老师，yynrzwh老师太感谢您们了，太辛苦您们了。您们的程序运行快，结果准确，我要慢慢学习体会。
类似的数据，用您们的程序，可以不走透视过程了，提高效率。
同时，请恕我无知，我原想能有通用模式，例如对数值型的指标，对文本型的指标。原来每一项指标都要老师们费脑，费力逐一编辑。太感谢了，祝老师们龙年万事如意，事业成就，生活幸福。