关于字典求助

欧瑞博

字典原代码需要完善，向前辈，老师请教来了。见附件

gwjkkkkk

请参考...

剑指E

欧瑞博

gwjkkkkk 发表于 2023-3-23 19:57
请参考...

谢谢！慢慢学习一下

zxsea_7426

凑热闹也参与，采用多级字典

1. Sub 统计发送()
   
2.     Dim arr, brr, ar, i&, j&, s$, d As Object, r, ws&
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     f = Dir(ThisWorkbook.Path & "\参数\需要提取的对象表.xls*.")
   
7.     If f = "" Then MsgBox "找不到参数文件！": End
   
8.     Set wb = Workbooks.Open(ThisWorkbook.Path & "\参数" & f, 0)
   
9.     With wb.Worksheets("明细")
   
10.         ar = .Range("a2:n" & .Cells(Rows.Count, 1).End(3).Row)
    
11.     End With
    
12.     wb.Close False
    
13.     Set f = Nothing
    
14.     For i = 2 To UBound(ar)
    
15.         年度 = Format(ar(i, 1), "yyyy年")
    
16.         If Not d.exists(年度) Then Set d(年度) = CreateObject("Scripting.Dictionary")                           '一级年度字典
    
17.         If ar(i, 14) <> "" Then
    
18.             mc_sender = ar(i, 4) & "###" & ar(i, 14)
    
19.             If Not d(年度).exists(mc_sender) Then Set d(年度)(mc_sender) = CreateObject("Scripting.Dictionary")     '二级名称+发送人字典
    
20.             月份 = Format(ar(i, 1), "m月")
    
21.             d(年度)(mc_sender)(月份) = d(年度)(mc_sender)(月份) + ar(i, 10)
    
22.         End If
    
23.     Next
    
24.     With Sheets("发送")
    
25.         .[f2] = "2023年"
    
26.         .[h2] = "度 月 份 发 送 表"
    
27.         ws = .Cells(Rows.Count, 1).End(xlUp).Row
    
28.         If ws >= 5 Then .Range("A5:o" & ws).clearcontents
    
29.         For Each Key In d.keys
    
30.             If Key = "2023年" Then
    
31.                 .[a5].resize(d("2023年").Count, 1) = Application.Transpose(d("2023年").keys)
    
32.                 br = .[a4].resize(d("2023年").Count + 1, 15)
    
33.                 ReDim brr(1 To d("2023年").Count, 1 To 15)
    
34.                 For i = 2 To UBound(br)
    
35.                     brr(i - 1, 1) = Split(br(i, 1), "###")(0)
    
36.                     brr(i - 1, 2) = Split(br(i, 1), "###")(1)
    
37.                     For j = 3 To UBound(br, 2) - 1
    
38.                         If d("2023年")(br(i, 1)).exists(br(1, j)) Then
    
39.                             brr(i - 1, j) = d("2023年")(br(i, 1))(br(1, j))
    
40.                             brr(i - 1, UBound(brr, 2)) = brr(i - 1, UBound(brr, 2)) + d("2023年")(br(i, 1))(br(1, j))
    
41.                         End If
    
42.                     Next
    
43.                 Next
    
44.                 With .[a5].resize(UBound(brr), UBound(brr, 2))
    
45.                     .Value = brr
    
46.                     .Font.Name = "微软雅黑"
    
47.                     .Font.Size = 11
    
48.                     .Borders.LineStyle = 1
    
49.                     .HorizontalAlignment = xlCenter
    
50.                 End With
    
51.             End If
    
52.         Next Key
    
53.     End With
    
54.     Application.ScreenUpdating = True
    
55.     Application.DisplayAlerts = True
    
56. End Sub

复制代码

zxsea_7426

.................