请帮忙将表2的数据汇总到表1

fhqgyn

由于数据量太大,我写的运行时间太久,(运行完大概要30分钟)
本人不太会使用字典,请高手帮忙搞一下,提高运行时间,万分感谢~!

limonet

POWER QUERY二维表转一维表
定位到二维表任一单元格→数据→自表格/区域→创建表→确定→×更改的类型→把日期列数据改成【日期】→选定目标列→转换→逆透视列→主页→关闭并上载

fzxba

test1219.rar (461.87 KB, 下载次数: 12)

2022-12-19 09:40 上传

点击文件名下载附件

鄂龙蒙

test.rar (710.21 KB, 下载次数: 9)

2022-12-19 09:53 上传

点击文件名下载附件

ykcbf1100

求助帖说明太少，只能猜一下。

fhqgyn

是我要的结果,谢谢~!真是太厉害了

fhqgyn

ykcbf1100 发表于 2022-12-19 10:17
求助帖说明太少，只能猜一下。

是我要的结果,谢谢~!真是太厉害了

fhqgyn

fzxba 发表于 2022-12-19 09:40

谢谢,学习了.

一烟难禁

1. Sub test()
   
2. Dim h, i, j, k, arr, zrr, ss, tt
   
3. arr = Sheets("工作表2").Range("a1").CurrentRegion
   
4. zrr = Sheets("工作表1").Range("a1").CurrentRegion
   
5. Dim dic As Object
   
6. Set dic = CreateObject("scripting.dictionary")
   
7. For h = 2 To UBound(arr)
   
8.     ss = arr(h, 1) & "#" & arr(h, 2)
   
9.     dic(ss) = dic(ss) + arr(h, 3)
   
10. Next
    
11. For i = 2 To UBound(zrr)
    
12.     For j = 4 To UBound(zrr, 2)
    
13.         tt = zrr(i, 1) & "#" & zrr(1, j)
    
14.         If dic.exists(tt) Then
    
15.              zrr(i, j) = dic(tt)
    
16.         End If
    
17.     Next
    
18. Next
    
19. For i = 2 To UBound(zrr)
    
20.     k = 0
    
21.     For j = 3 To UBound(zrr, 2)
    
22.         If zrr(i, j) <> "" Then
    
23.             zrr(i, 3) = zrr(i, 3) + zrr(i, j)
    
24.             k = k + 1
    
25.         End If
    
26.         zrr(i, 2) = k
    
27.     Next
    
28. Next
    
29. Sheets("工作表1").Range("a1").CurrentRegion = zrr
    
30. End Sub

复制代码

你这个数据量不算大，函数也可以的