去重， 目前只能做到同车同客户求和在 I ...

youjinhu

Sub Test()
Dim a, ws As Worksheet, dic As Object, s As String, j As String, i As Long, r As Long

Set ws = ThisWorkbook.Sheets("Sheet2")
Set dic = CreateObject("scripting.dictionary")
a = ws.Range("A2:F" & ws.Cells(Rows.Count, 1).End(xlUp).Row).Value

For i = LBound(a, 1) To UBound(a, 1)
    s = a(i, 1) & vbTab & a(i, 2)
    If Not dic.Exists(s) Then dic(s) = Array(, , 0)
    dic(s) = Array(a(i, 1), a(i, 2), dic(s)(2) + a(i, 5))

Next i
ws.Range("G2").Resize(dic.Count, 3).Value = Application.Transpose(Application.Transpose(dic.items))


End Sub

xunanming

请参考-------------------------

shiruiqiang

youjinhu

xunanming 发表于 2023-5-24 03:29
请参考-------------------------

非常感谢，大神指导

youjinhu

shiruiqiang 发表于 2023-5-24 07:26

感谢大神指导

feilanga

多用几个字典一样。

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, i&, j&, r&, p&, dic As Object, strKey$
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = [A1].CurrentRegion
    ReDim br(1 To UBound(ar), 1 To 5)
    For i = 2 To UBound(ar)
        strKey = ar(i, 1) & "|" & ar(i, 2)
        If Not dic.exists(strKey) Then
            r = r + 1
            br(r, 1) = ar(i, 1): br(r, 2) = ar(i, 2)
            dic(strKey) = r
        End If
        p = dic(strKey)
        For j = 4 To 6
            br(p, j - 1) = br(p, j - 1) + ar(i, j)
        Next j
    Next i
   
    Columns("H:L").Clear
    [H1].Resize(, 5) = Split("车辆单位 客户 柜量 运费 杂费")
    [H2].Resize(r, 5) = br
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

参与一下。。。

510437958

xunanming 发表于 2023-5-24 03:29
请参考-------------------------

https://club.excelhome.net/thread-1663511-1-1.html老师有兴趣看看这个问题吗？

ykcbf1100

参与一下。

这是在楼主自己的代码基础上修改的。