[已解决]两个表格对应内容匹配乘积数据汇总在新表格中

哥儿- · 发表于 2022-12-7 11:20

应该是这个意思，你添加新的数据进去测试一下……

su77 · 发表于 2022-12-7 13:20

哥儿- 发表于 2022-12-7 11:20
应该是这个意思，你添加新的数据进去测试一下……

非常感谢，但运算结果还是差一步。还是需要在需求汇总里先把对应的产品明细列示在那里，才能算出对应的需求数量，如果需求汇总里清空了，就运算不出结果，需求汇总表会是空白的。我需要的是需求汇总原本是没有数据的，运算之后，把运算的结果放在里面。比如，第一次在需求明细里有产品A，产品B，产品C，产品D的需求数量，运算后需求汇总里就有产品A，产品B，产品C，产品D对应的产品明细的需求数量的乘积和；而第二次在需求明细里只有产品E，运算后需求汇总里就只有产品E对应的产品明细的需求数量的乘积和。麻烦您啦！

哥儿- · 发表于 2022-12-7 14:29

su77 发表于 2022-12-7 13:20
非常感谢，但运算结果还是差一步。还是需要在需求汇总里先把对应的产品明细列示在那里，才能算出对应的需 ...

Sub test()
Dim arr, brr, dic As Object, d As Object, d1 As Object
Dim i&, j&, k, crr, temp$, num&, ik
arr = Sheet3.Range("A1").CurrentRegion
crr = Sheet1.Range("A1").CurrentRegion.Resize(, 4)
Set dic = CreateObject("scripting.dictionary")
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
ReDim brr(1 To 6)
For i = 2 To UBound(arr)
If Not dic.exists(arr(i, 2)) Then
For j = 2 To UBound(arr, 2) - 4
brr(j - 1) = arr(i, j)
Next
d1(arr(i, 2)) = brr
Set dic(arr(i, 2)) = CreateObject("scripting.dictionary")
End If
dic(arr(i, 2))(arr(i, 1)) = arr(i, 10)
Next i
For i = 2 To UBound(crr)
d(crr(i, 1)) = crr(i, 4)
Next i
ReDim brr(1 To dic.Count, 1 To 8)
For i = 0 To dic.Count - 1
temp = dic.keys()(i)
For Each ik In d1(temp)
num = num + 1
brr(i + 1, num) = ik
Next ik
num = 0
For Each k In dic(temp).keys
brr(i + 1, 8) = brr(i + 1, 8) + d(k) * dic(temp)(k)
Next k
Next i
Sheet2.[a2:h10000].ClearContents
Sheet2.[a2].Resize(UBound(brr), UBound(brr, 2)) = brr
Set dic = Nothing
Set d = Nothing
Set d1 = Nothing
End Sub

复制代码

试试

su77 · 发表于 2022-12-7 15:07

哥儿- 发表于 2022-12-7 14:29
试试

这个代码运行的结果会出现，产品D只有3个产品明细，但是如果在需求明细里，把产品A、B、C的需求数量清为空，只有产品D有需求数量100，在需求汇总表里还是所有的产品明细，只是产品D没有的需求数量都填为0；而我把产品A、B、C在需求明细里都删除，只留下产品D，需求汇总表里也还是所有明细，没有的需求数理都为0。如果想要需求明细里需求数量不为空的才进行乘积和的汇总，而需求数量为空的产品对应的产品明细不进行乘积汇总，即不在需求汇总里显示，这个代码如何改呢？

哥儿- · 发表于 2022-12-7 15:41

su77 发表于 2022-12-7 15:07
这个代码运行的结果会出现，产品D只有3个产品明细，但是如果在需求明细里，把产品A、B、C的需求数量清为 ...

Sub test()
Dim arr, brr, dic As Object, d As Object, d1 As Object
Dim i&, j&, k, crr, temp$, num&, ik, sm, n
arr = Sheet3.Range("A1").CurrentRegion
crr = Sheet1.Range("A1").CurrentRegion.Resize(, 4)
Set dic = CreateObject("scripting.dictionary")
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
ReDim brr(1 To 6)
For i = 2 To UBound(arr)
If Not dic.exists(arr(i, 2)) Then
For j = 2 To UBound(arr, 2) - 4
brr(j - 1) = arr(i, j)
Next
d1(arr(i, 2)) = brr
Set dic(arr(i, 2)) = CreateObject("scripting.dictionary")
End If
dic(arr(i, 2))(arr(i, 1)) = arr(i, 10)
Next i
For i = 2 To UBound(crr)
d(crr(i, 1)) = crr(i, 4)
Next i
ReDim brr(1 To dic.Count, 1 To 8)
For i = 0 To dic.Count - 1
temp = dic.keys()(i)
For Each k In dic(temp).keys
sm = sm + d(k) * dic(temp)(k)
Next k
If sm > 0 Then
n = n + 1
brr(n, 8) = sm
For Each ik In d1(temp)
num = num + 1
brr(n, num) = ik
Next ik
num = 0
sm = 0
End If
Next i
Sheet2.[a2:h10000].ClearContents
Sheet2.[a2].Resize(UBound(brr), UBound(brr, 2)) = brr
Set dic = Nothing
Set d = Nothing
Set d1 = Nothing
End Sub

复制代码

调整了，测试一下……

su77 · 发表于 2022-12-7 16:21

哥儿- 发表于 2022-12-7 15:41
调整了，测试一下……

万分感谢，这个代码是对的！

		自动登录	找回密码
密码			注册