求教各位大神，老师们：VBA多条件求和代码，万分感谢！

冬日暖阳A

求教各位大神，老师们：VBA多条件求和代码，以存货编码/采购订单号/日期为条件，合并计算到货单列里的每日来料数量，要求保留H/N/Q/R列和第一行的函数公式，万分感谢！

v

3190496160

Sub 求和()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("到货单列表")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "到货单列表为空！": End
    br = .Range("a1:k" & r)
End With
With Sheets("请购明细")
    rs = .Cells(Rows.Count, 1).End(xlUp).Row
    If rs < 2 Then MsgBox "请购明细为空！": End
    .Range("s3:aq" & rs) = Empty
    ar = .Range("a2:aq" & rs)
    For i = 2 To UBound(ar)
        If Trim(ar(i, 2)) <> "" And Trim(ar(i, 11)) <> "" Then
            zd = Trim(ar(i, 2)) & "|" & Trim(ar(i, 11))
            d(zd) = i
        End If
    Next i
    For j = 19 To UBound(ar, 2)
        d(ar(1, j)) = j
    Next j
    For i = 2 To UBound(br)
        zd = Trim(br(i, 7)) & "|" & Trim(br(i, 3))
        xh = d(zd)
        lh = d(br(i, 5))
        If xh <> "" And lh <> "" Then
            ar(xh, lh) = ar(xh, lh) + br(i, 11)
        End If
    Next i
    For j = 19 To UBound(ar, 2)
        .Cells(2, j).Resize(UBound(ar), 1) = Application.Index(ar, 0, j)
    Next j
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

3190496160

结果未核对，代码仅供参考
5月份彩盒下单明细表.rar (265.7 KB, 下载次数: 10)

2023-5-14 09:10 上传

点击文件名下载附件

冬日暖阳A

非常感谢大神的帮助，就是要这种效果，核对过结果是对的，太好了，太赞了！