VBA 合并同类项并求和

巴巴搏

我的代码：
Sub test()
Dim arr, k%, brr(), n%, d, dstr$, h%, x
arr = Range("h1").CurrentRegion
Set d = CreateObject("scripting.dictionary")
For k = 2 To UBound(arr)
    dstr = arr(k, 5) & arr(k, 8)
    If d.exists(dstr) = False Then
        n = n + 1
        d(dstr) = n
        ReDim Preserve brr(1 To 3, 1 To n)
        brr(1, n) = arr(k, 5)
        brr(2, n) = arr(k, 8)
        brr(3, n) = arr(k, 4)
    Else
        h = d(dstr)
        brr(3, h) = brr(3, h) + arr(k, 4)

    End If
Next k
Range("o1") = arr(1, 5): Range("p1") = arr(1, 8): Range("q1") = arr(1, 4)
Range("o2").Resize(UBound(brr, 2), 3) = Application.WorksheetFunction.Transpose(brr)
End Sub
应该是代码出现了问题

巴巴搏

求大神帮忙，谢谢了。最右边那一列按正确来算应该是：20,20,50,40,100......

巴巴搏

我的代码：
Sub test()
Dim arr, k%, brr(), n%, d, dstr$, h%, x
arr = Range("h1").CurrentRegion
Set d = CreateObject("scripting.dictionary")
For k = 2 To UBound(arr)
    dstr = arr(k, 5) & arr(k, 8)
    If d.exists(dstr) = False Then
        n = n + 1
        d(dstr) = n
        ReDim Preserve brr(1 To 3, 1 To n)
        brr(1, n) = arr(k, 5)
        brr(2, n) = arr(k, 8)
        brr(3, n) = arr(k, 4)
    Else
        h = d(dstr)
        brr(3, h) = brr(3, h) + arr(k, 4)

    End If
Next k
Range("o1") = arr(1, 5): Range("p1") = arr(1, 8): Range("q1") = arr(1, 4)
Range("o2").Resize(UBound(brr, 2), 3) = Application.WorksheetFunction.Transpose(brr)
End Sub
应该是代码出现了问题

正确计算的是在右边是20 20 50 40 100 ......

巴巴搏

求大神帮忙，谢谢了。最右边那一列按正确来算应该是：20,20,50,40,100......

大灰狼1976

大哥真是锲而不舍啊，告诉你得不到答复的原因吧，附件附件附件！
如果真的不方便上传附件，至少图片要包含所有必需信息，行列号是最基本的。
就问题而言，是很简单的，就是用字典合并同类项。

lisachen

上传附件

zhxl0562

Sub test()
Dim arr, k%, brr(), n%, d, dstr$, h%, x
arr = Range("h1").CurrentRegion
Set d = CreateObject("scripting.dictionary")
For k = 2 To UBound(arr)
    dstr = arr(k, 5) & arr(k, 8)
    If d.exists(dstr) = False Then
        n = n + 1
        d(dstr) = n
        ReDim Preserve brr(1 To 3, 1 To n)
        brr(1, n) = arr(k, 5)
        brr(2, n) = arr(k, 8)
        brr(3, n) = arr(k, 4)
    Else
        h = d(dstr)
        brr(3, h) = brr(3, h) + (arr(k, 4) * 1)

    End If
Next k
Range("o1") = arr(1, 5): Range("p1") = arr(1, 8): Range("q1") = arr(1, 4)
Range("o2").Resize(UBound(brr, 2), 3) = Application.WorksheetFunction.Transpose(brr)
End Sub
文本格式转为数字就可以了