根据表2B列内容从表1查找对应数据

ykcbf1100

附件太大，无法上传，就发个图吧。

沈默00

沈默00

文件太大了，运行有点慢，17秒，有待优化

yynrzwh

1. Sub test()
   
2. 
   
3. Set d = VBA.CreateObject("scripting.dictionary")
   
4. arr = Sheet1.UsedRange
   
5.     For i = 2 To UBound(arr)
   
6.         d(arr(i, 3)) = d(arr(i, 3)) & "|" & i
   
7.     Next i
   
8. 
   
9. ReDim brr(1 To d.Count, 1 To 12)
   
10.     For Each k In d.keys
    
11.         r = r + 1
    
12.         brr(r, 1) = k
    
13.         sp = Split(Mid(d(k), 2), "|")
    
14.         brr(r, 2) = UBound(sp) + 1
    
15.         brr(r, 3) = arr(sp(0) * 1, 11)
    
16.             s1 = 0: s2 = 0
    
17.             For x = 0 To UBound(sp)
    
18.                 s1 = s1 + arr(sp(x) * 1, 7)
    
19.                 s2 = s2 + arr(sp(x) * 1, 9)
    
20.             Next x
    
21.         brr(r, 4) = arr(sp(0) * 1, 7)
    
22.         brr(r, 5) = arr(sp(0) * 1, 9)
    
23.         brr(r, 6) = s1
    
24.         brr(r, 7) = s2
    
25.         brr(r, 8) = arr(sp(0) * 1, 2)
    
26.         brr(r, 9) = arr(sp(0) * 1, 5)
    
27.         brr(r, 10) = arr(sp(0) * 1, 4)
    
28.         brr(r, 11) = brr(r, 2) * brr(r, 3)
    
29.     Next k
    
30. Sheet2.UsedRange.Offset(1) = ""
    
31. Sheet2.Range("b3").Resize(r, 12) = brr
    
32. Set d = Nothing
    
33. End Sub
    

复制代码

沈默00

文件太大，上传不了，删除了表2的部分数据，试一下

他们

ykcbf1100 发表于 2024-1-16 08:11
附件太大，无法上传，就发个图吧。

非常感谢 非常感谢 非常感谢

他们

yynrzwh 发表于 2024-1-16 10:11

谢谢  非常感谢，速度挺快，要是工作簿中有很多张工作表（表1---------表20）把代码里面的表1和表2换成表15和表16能查出来数据吗，

yynrzwh

他们 发表于 2024-1-16 12:54
谢谢  非常感谢，速度挺快，要是工作簿中有很多张工作表（表1---------表20）把代码里面的表1和表2换成表 ...

多表要套一个循环。
for each sh in sheets

next

他们

yynrzwh 发表于 2024-1-16 15:23
多表要套一个循环。
for each sh in sheets

不知道加到哪儿

yynrzwh

上附件看看