有关字典嵌套数据汇总问题

大公臻信

老师：

我想学习字典嵌套方法。通过字典嵌套汇总数据。代码如下：

Sub 字典嵌套数据汇总()

Set psht1 = Sheets("原始数据")
Set psht2 = Sheets("数据汇总")

psht1.Select
phj = psht1.Range("A:A").Cells.Find("合计").Row
'数组应包括标题行标题列
arr = psht1.Range("a1:E" & phj - 1)
'以项目序号定义父字典
Set Dic = CreateObject("scripting.dictionary")
'再以项目序号关键字创建子字典
For xhxh = 2 To UBound(arr, 1)
    If Not Dic.Exists(arr(xhxh, 1)) Then
        Set Dic(arr(xhxh, 1)) = CreateObject("scripting.dictionary")
    End If
    '通过字典获取不重名项目序号
    Dic(arr(xhxh, 1)) = ""
Next
'利用字典嵌套多列求和
'第1行为标题行
For xhxh1 = 2 To UBound(arr, 1)
    '第1、第2列为项目序号、名称，不求和
    For xhxh2 = 1 To UBound(arr, 2) - 2
        Dic(arr(xhxh1, 1))(arr(1, xhxh2 + 1)) = Dic(arr(xhxh1, 1))(arr(1, xhxh2 + 1)) + arr(xhxh1, xhxh2 + 1)
    Next
Next
psht2.Select
prwb = psht2.UsedRange.Rows.Count
Range("a2").Resize(Dic.Count, 1) = Application.Transpose(Dic.keys)
'利用字典嵌套填入求和数据
'第1行为标题行
For xhxh1 = 2 To prwb - 1
    '第1、第2列为项目序号、名称，不求和
    For xhxh2 = 2 To UBound(arr, 2)
        Cells(xhxh1 + 2, xhxh2 + 1) = Dic(Cells(xhxh1 + 1, 1))(Cells(1, xhxh2 + 1))
    Next
Next
End Sub


标为红色的语句 浮标提示  “类型不匹配”
将此句修改为：Dic(arr(xhxh1, 1).Value)(arr(1, xhxh2 + 1)) = Dic(arr(xhxh1, 1).Value)(arr(1, xhxh2 + 1)) + arr(xhxh1, xhxh2 + 1)后
浮标提示  “要求对象”

请老师，帮看看，指导，谢谢 字典嵌套数据汇总.zip (17.12 KB, 下载次数: 25)

2024-5-9 10:54 上传

点击文件名下载附件

蓝桥玄霜

字典的例子：

taller

大公臻信

感谢蓝桥玄霜老师！感谢taller老师！向两位老师致敬！

大公臻信

taller老师
您的代码，帮我实现了目标，也找到了标红语句 类型不匹配 的原因是多了以下 这句
dic(arr(xhxh, 1)) = ""  
去掉这句，问题消除了。
原本我想通过这一语句，获取表中序号列序号唯一值，填入表2。而这一目标通过以下语句实现
dic(arr(xhxh1, 1))(arr(1, xhxh2)) = dic(arr(xhxh1, 1))(arr(1, xhxh2)) + arr(xhxh1, xhxh2)
Range("a2").Resize(dic.Count, 1) = Application.Transpose(dic.keys)

dic(arr(xhxh, 1)) = ""  这句是多余的

请教taller 老师，为何多了这句，导致 dic(arr(xhxh1, 1))(arr(1, xhxh2)) = dic(arr(xhxh1, 1))(arr(1, xhxh2)) + arr(xhxh1, xhxh2) 这句出现类型不匹配错误。

谢谢taller老师！

ykcbf1100

参与一下，一个字典

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.5.9
   
2.     Dim arr, brr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     With Sheets("原始数据")
   
6.         r = .Cells(Rows.Count, 1).End(3).Row
   
7.         arr = .[a1].Resize(r, 5)
   
8.     End With
   
9.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2) + 1)
   
10.     For i = 2 To UBound(arr) - 1
    
11.         s = arr(i, 1)
    
12.         If Not d.Exists(s) Then
    
13.             m = m + 1
    
14.             d(s) = m
    
15.             brr(m, 1) = s
    
16.             For j = 2 To UBound(arr, 2)
    
17.                 brr(m, j) = arr(i, j)
    
18.             Next
    
19.         Else
    
20.             r = d(s)
    
21.             For x = 2 To UBound(arr, 2)
    
22.                 brr(r, x) = brr(r, x) + arr(i, x)
    
23.             Next
    
24.         End If
    
25.     Next
    
26.     With Sheets("数据汇总")
    
27.         .UsedRange.Offset(1) = ""
    
28.         .Range("a2").Resize(m, 6) = brr
    
29.         .Range("a1").Resize(m + 2, 6).Borders.LineStyle = 1
    
30.         r = .Cells(Rows.Count, 1).End(3).Row
    
31.         For i = 2 To m + 1
    
32.             For j = 2 To 5
    
33.                 .Cells(i, 6) = Application.WorksheetFunction.Sum(.Cells(i, 2).Resize(1, 4))
    
34.             Next
    
35.         Next
    
36.         .Cells(r + 1, 1) = "合计"
    
37.         .Cells(r + 1, 2).Resize(1, 5).FormulaR1C1 = "=SUM(R2C:R" & "[-1]C)"
    
38.     End With
    
39.     Set d = Nothing
    
40.     Application.ScreenUpdating = True
    
41.     MsgBox "OK！"
    
42. End Sub
    

复制代码

ykcbf1100

一个字典，写法2，全表自动生成。

ykcbf1100

参与一下。。。

1. Sub ykcbf2()  '//2024.5.9   全表自动生成
   
2.     Dim arr, brr, d
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Sheets("原始数据")
   
7.         r = .Cells(Rows.Count, 2).End(3).Row
   
8.         arr = .Range("a1").Resize(r, 5)
   
9.     End With
   
10.     ReDim brr(1 To UBound(arr), 1 To 100)
    
11.     brr(1, 1) = arr(1, 1)
    
12.     m = 1: n = 1
    
13.     For i = 2 To UBound(arr) - 1
    
14.         s = arr(i, 1)
    
15.         If Not d.exists(s) Then
    
16.             m = m + 1
    
17.             d(s) = m
    
18.             brr(m, 1) = s
    
19.         End If
    
20.         r = d(arr(i, 1))
    
21.         For j = 2 To UBound(arr, 2)
    
22.             s = arr(1, j)
    
23.             If Not d.exists(s) Then
    
24.                 n = n + 1
    
25.                 d(s) = n
    
26.                 brr(1, n) = arr(1, j)
    
27.             End If
    
28.             c = d(arr(1, j))
    
29.             brr(r, c) = brr(r, c) + arr(i, j)
    
30.         Next
    
31.     Next
    
32.     With Sheets("数据汇总")
    
33.         .UsedRange.Clear
    
34.         .[a1].Resize(1, n + 1).Interior.Color = 49407
    
35.         .[a2].Resize(m - 1, 1).Interior.Color = 5296274
    
36.         With .[a1].Resize(m + 1, n + 1)
    
37.             .Value = brr
    
38.             .Borders.LineStyle = 1
    
39.             .HorizontalAlignment = xlCenter
    
40.             .VerticalAlignment = xlCenter
    
41.             With .Font
    
42.                 .Name = "微软雅黑"
    
43.                 .Size = 11
    
44.             End With
    
45.         End With
    
46.         .Cells(1, n + 1) = "合计"
    
47.         For i = 2 To m + 1
    
48.             .Cells(i, n + 1) = Application.WorksheetFunction.Sum(.Cells(i, 2).Resize(1, 4))
    
49.         Next
    
50.         m = m + 1
    
51.         .Cells(m, "a") = "合计"
    
52.         .Cells(m, "b").Resize(1, n).FormulaR1C1 = "=SUM(R2C:R" & "[-1]C)"
    
53.     End With
    
54.     Set d = Nothing
    
55.     MsgBox "OK！"
    
56. End Sub
    

复制代码

shiruiqiang

sql