求助编制程序（已解决）

zhouxiao

供参考

1. Sub test()
   
2.     Dim d, Arr
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheet2 's("明细科目审定表")
   
5.         MX_last_range = .Range("A8").End(xlDown).Row
   
6.         Arr = .Range("a8:X" & MX_last_range)
   
7.         For i = 1 To UBound(Arr)
   
8.             s = Arr(i, 24)
   
9.             d(s) = d(s) + Arr(i, 12)
   
10.         Next
    
11.     End With
    
12.     With Sheet15 's("会计科目审定表")
    
13.         KM_last_range = .Range("A8").End(xlDown).Row
    
14.         .Range("d8:n" & KM_last_range).ClearContents
    
15.         For i = 8 To KM_last_range
    
16.             s = .Cells(i, 1).Value
    
17.             If d.exists(s) Then .Cells(i, 4).Value = d(s)
    
18.         Next
    
19.     End With
    
20. End Sub

复制代码

zhouxiao

楼主已经注册11年了,也该抽空学习一下呵.

yjm0809

谢谢啊，呵呵

yjm0809

zhouxiao 发表于 2018-7-28 13:52
楼主已经注册11年了,也该抽空学习一下呵.

谢谢啊，我只是用的时候学下，呵呵

yjm0809

zhouxiao 发表于 2018-7-28 13:50
供参考

你好，再请教下，如果想汇总多列，就得定义多个字典d\d1\d2....,是吗？

yjm0809

用了9个字典，请问，还能优化吗？

Sub test()
  Application.ScreenUpdating = False: Application.DisplayAlerts = False  '//????????????
  t = Timer  '//?趨??????
  Dim d, d1, d2, d3, d4, d5, d6, d7, d8, d9, arr
  Set d = CreateObject("Scripting.Dictionary")
  Set d1 = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  Set d3 = CreateObject("Scripting.Dictionary")
  Set d4 = CreateObject("Scripting.Dictionary")
  Set d5 = CreateObject("Scripting.Dictionary")
  Set d6 = CreateObject("Scripting.Dictionary")
  Set d7 = CreateObject("Scripting.Dictionary")
  Set d8 = CreateObject("Scripting.Dictionary")
  Set d9 = CreateObject("Scripting.Dictionary")
  With Sheets("??????????")
    MX_last_range = .Range("A8").End(xlDown).Row
    arr = .Range("a8:X" & MX_last_range)
    For i = 1 To UBound(arr)
        s = arr(i, 24)
        d(s) = d(s) + arr(i, 12)
        d1(s) = d1(s) + arr(i, 8)
        d2(s) = d2(s) + arr(i, 9)
        d3(s) = d3(s) + arr(i, 18)
        d4(s) = d4(s) + arr(i, 19)
        d5(s) = d5(s) + arr(i, 20)
        d6(s) = d6(s) + arr(i, 21)
        d7(s) = d7(s) + arr(i, 22)
        d8(s) = d8(s) + arr(i, 23)
        d9(s) = d9(s) + arr(i, 17)
    Next
  End With
  With Sheets("?????????")
    KM_last_range = .Range("A8").End(xlDown).Row
    .Range("d8:n" & KM_last_range).ClearContents
    For i = 8 To KM_last_range
        s = .Cells(i, 1).Value
        If d.exists(s) Then .Cells(i, 4).Value = d(s)
        If d1.exists(s) Then .Cells(i, 5).Value = d1(s)
        If d2.exists(s) Then .Cells(i, 6).Value = d2(s)
        If d3.exists(s) Then .Cells(i, 7).Value = d3(s)
        If d4.exists(s) Then .Cells(i, 8).Value = d4(s)
        If d5.exists(s) Then .Cells(i, 9).Value = d5(s)
        If d6.exists(s) Then .Cells(i, 10).Value = d6(s)
        If d7.exists(s) Then .Cells(i, 11).Value = d7(s)
        If d8.exists(s) Then .Cells(i, 12).Value = d8(s)
        If d9.exists(s) Then .Cells(i, 13).Value = d9(s)
    Next
  End With
  ActiveWorkbook.Save
  Application.ScreenUpdating = True: Application.DisplayAlerts = True
  MsgBox "????????" & Format(Timer - t, "#0.0000") & " ??", , "???????????"      '//??????????
End Sub

zhouxiao

yjm0809 发表于 2018-7-28 15:07
你好，再请教下，如果想汇总多列，就得定义多个字典d\d1\d2....,是吗？

一个字典就可以，可以用科目编码+列字段名组成一个新的关键字，用字典给它赋值，同理，在结果表中查询返回结果时，将结果表里的科目编码+列字段名组成新关键字，查询前面已经存入字典里的结果，符合条件的就返回.
方法有很多，可以用vba+字典、vba+sql、sql+透视表、power query，如果列比较多的，用后面2种方法，要简单方便很多.