求助，通过VBA字典多条件求和

lixinghui1992

多条件一个和能求，多条件多个和求助怎么解决，附近这个结果一直是0

longwin

Sub test()
Set d = CreateObject("scripting.dictionary")
arr = Sheet1.[a1].CurrentRegion
For i = 1 To UBound(arr)
    tj = arr(i, 1) & "/" & arr(i, 2)
    If Not d.exists(tj) Then
        d(tj) = Array(arr(i, 3), arr(i, 4))
    Else
        d(tj) = Array(d(tj)(0) + arr(i, 3), d(tj)(1) + arr(i, 4))
    End If
Next
ReDim brr(1 To d.Count, 1 To 4)
For Each key In d.keys
    m = m + 1
    brr(m, 1) = Split(key, "/")(0)
    brr(m, 2) = Split(key, "/")(1)
    brr(m, 3) = d(key)(0)
    brr(m, 4) = d(key)(1)
Next
Sheet1.[f1].Resize(m, 4) = brr
End Sub

lsc900707

参考测试附件：

Qs18

Sub qs() '2024/7/6
    Dim arr, brr, dic, i
    Set dic = CreateObject("scripting.dictionary")
    With Sheet1
        arr = .Range("a1").CurrentRegion.Value
        ReDim brr(1 To UBound(arr), 1 To 4)
        For i = 2 To UBound(arr)
            s = arr(i, 1) & "|" & arr(i, 2)
            If Not dic.exists(s) Then
                m = m + 1
                dic(s) = m
                brr(m, 1) = arr(i, 1): brr(m, 2) = arr(i, 2): brr(m, 3) = Val(arr(i, 3)): brr(m, 4) = Val(arr(i, 4))
            Else
                r = dic(s)
                brr(r, 3) = brr(r, 3) + Val(arr(i, 3)): brr(r, 4) = brr(r, 4) + Val(arr(i, 4))
            End If
        Next
        .Range("f1:i10000").ClearContents
        .Range("f1").Resize(1, 4) = Application.Index(arr, 1, 0)
        .Range("f2").Resize(m, 4) = brr
    End With
    Set dic = Nothing
End Sub

Qs18

试试...............

Qs18

试试............

lixinghui1992

longwin 发表于 2024-7-5 23:56
Sub test()
Set d = CreateObject("scripting.dictionary")
arr = Sheet1.[a1].CurrentRegion

感谢老师帮助，谢谢

lixinghui1992

Qs18 发表于 2024-7-6 07:49
试试............

感谢老师帮助 谢谢

lixinghui1992

lsc900707 发表于 2024-7-6 06:46
参考测试附件：

感谢老师帮助，谢谢

feilanga