需拆分的数据求和

zllyyz

请各位老师指教，需求如下图，谢谢

cnmlgb9998

你那个演示表，为什么要搞成这种不规范的有重名列 的表？？？？？搞成一列，不行？？？？？非要把自己绕进去？把人家也绕进去？

cnmlgb9998

使用PQ ，一句代码的事。。。。。。。。。。。。。。。


随你两张表怎么增加或减少，能即时更新。

zllyyz

cnmlgb9998 发表于 2024-3-17 21:46
你那个演示表，为什么要搞成这种不规范的有重名列 的表？？？？？搞成一列，不行？？？？？非要把自己绕进 ...

因为就是有这样的需求…有难度得话是不是可以一个程序对应一个 类取一个金额 是不是简单多了？

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.3.18
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     With Sheets("Sheet1")
   
4.         r = .Cells(Rows.Count, 1).End(3).Row
   
5.         arr = .[a1].Resize(r, 4)
   
6.     End With
   
7.     For i = 4 To UBound(arr)
   
8.         s = CStr(arr(i, 3))
   
9.         d(s) = arr(i, 4)
   
10.     Next
    
11.     On Error Resume Next
    
12.     With Sheets("Sheet2")
    
13.         rq1 = .[d3]: rq2 = .[e3]
    
14.         r = .Cells(Rows.Count, 1).End(3).Row
    
15.         arr = .[a1].Resize(r, 5)
    
16.         For i = 5 To UBound(arr)
    
17.             For j = 2 To UBound(arr, 2) Step 2
    
18.                 st = Split(arr(i, j), ",")
    
19.                 Sum = 0
    
20.                 For x = 0 To UBound(st)
    
21.                     If InStr(CStr(st(x)), rq1 & rq2) Then
    
22.                         Sum = Sum + d(CStr(st(x)))
    
23.                     End If
    
24.                 Next
    
25.                 .Cells(i, j + 1) = Sum
    
26.             Next
    
27.         Next
    
28.     End With
    
29.     MsgBox "OK！"
    
30. End Sub
    
31. 
    

复制代码

zllyyz

ykcbf1100 发表于 2024-3-18 08:38
附件供参考。。。

感谢 老师提供思路
期待有大大能写出“神”代码