跨表提取不重复数据并按条件汇总（去重求和）

icenotcool

ykcbf1100 发表于 2024-9-29 10:33
参与一下。。。

非常感谢ykcbf1100老师的帮助！

翁知江安

你的sheets("汇总"）的A列的格式有问题，应该为文本。

翁知江安

Sub totala()
Dim m, j, k, irow
Dim arr
Dim d1 As Object
Dim d2 As Object
Dim d3 As Object
Dim d4 As Object
Dim d5 As Object
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")
irow = Sheets("系统导出").[a1].End(xlDown).Row
arr = Sheets("系统导出").Range("a1:i" & irow)
For m = 2 To UBound(arr)
    d1(arr(m, 1)) = ""
    d2(arr(m, 1)) = d2(arr(m, 1)) + arr(m, 7)
    d3(arr(m, 1)) = d3(arr(m, 1)) + arr(m, 9)
    d4(arr(m, 1)) = arr(m, 2)
    d5(arr(m, 1)) = arr(m, 3)
Next
Sheets("汇总").[a2].Resize(d1.Count, 1) = Application.WorksheetFunction.Transpose(d1.keys)
Sheets("汇总").[b2].Resize(d4.Count, 1) = Application.WorksheetFunction.Transpose(d4.items)
Sheets("汇总").[c2].Resize(d5.Count, 1) = Application.WorksheetFunction.Transpose(d5.items)
Sheets("汇总").[e2].Resize(d2.Count, 1) = Application.WorksheetFunction.Transpose(d2.items)
Sheets("汇总").[f2].Resize(d3.Count, 1) = Application.WorksheetFunction.Transpose(d3.items)

For j = 2 To d1.Count + 1
   Sheets("汇总").Cells(j, 4) = Sheets("汇总").Cells(j, 6) / Sheets("汇总").Cells(j, 5)
Next

End Sub

翁知江安

完全可以用字典操作

icenotcool

谢谢你的帮助和建议

icenotcool

lsc900707 发表于 2024-9-27 22:21
参考测试附件：

lsc900707老师，可以抽空看看我的求助帖吗？麻烦您啦https://club.excelhome.net/thread-1703113-1-1.html

lsc900707

icenotcool 发表于 2024-10-6 12:18
lsc900707老师，可以抽空看看我的求助帖吗？麻烦您啦https://club.excelhome.net/thread-1703113-1-1.htm ...

假期在外面玩呢