[已解决]求和汇总且转换表样式

图不安兔

论坛各位老师好！肯请帮我用VBA代码实现附件里函数公式模拟的结果。多谢！

最佳答案

月排行榜 / 总排行榜

哥儿-

2022-8-19 10:59

图不安兔 发表于 2022-8-19 06:10
谢谢您！哥儿-老师。如果要进步对数据进行去重汇总求和，咋改写代码？（请您随意复制几个放在原数据下面 ...

加个字典去重。
Sub test()
    Application.DisplayAlerts = False
    Dim arr, brr, i&, j%, n&, num&, str$, crr, drr
    Dim dic As Object
    Set dic = CreateObject("scripting.dictionary")
    arr = Sheet1.Range("A1").CurrentRegion
    num = Application.CountA(Sheet1.Range("c2:l" & UBound(arr)))
    Sheet2.[a2:d100000].ClearContents
    ReDim brr(1 To num, 1 To 4)
    For i = 2 To UBound(arr)
        For j = 3 To UBound(arr, 2)
            If arr(i, j) <> "" Then
                n = n + 1
                brr(n, 1) = arr(i, 1)
                brr(n, 2) = arr(i, 2)
                brr(n, 3) = arr(1, j)
                brr(n, 4) = arr(i, j)
                str = brr(n, 1) & "/" & brr(n, 2) & "/" & brr(n, 3)
                dic(str) = dic(str) + brr(n, 4) * 1
            End If
        Next
    Next
    crr = dic.keys
    drr = dic.items
    Erase arr
    ReDim brr(1 To dic.Count, 1 To 4)
    For i = 0 To UBound(crr)
        arr = Split(crr(i), "/")
        brr(i + 1, 1) = arr(0)
        brr(i + 1, 2) = arr(1)
        brr(i + 1, 3) = arr(2)
        brr(i + 1, 4) = drr(i)
    Next
    Sheet2.Range("a2").Resize(UBound(brr), 4) = brr
    Application.DisplayAlerts = True
End Sub

跳转到最佳答案楼层

哥儿-

Sub test()
    Application.DisplayAlerts = False
    Dim arr, brr, i&, j%, n&, num&
    arr = Sheet1.Range("A1").CurrentRegion
    num = Application.CountA(Sheet1.Range("c2:l" & UBound(arr)))
    Sheet2.[a2:d100000].ClearContents
    ReDim brr(1 To num, 1 To 4)
    For i = 2 To UBound(arr)
        For j = 3 To UBound(arr, 2)
            If arr(i, j) <> "" Then
                n = n + 1
                brr(n, 1) = arr(i, 1)
                brr(n, 2) = arr(i, 2)
                brr(n, 3) = arr(1, j)
                brr(n, 4) = arr(i, j)
            End If
        Next
    Next
    Sheet2.Range("a2").Resize(UBound(brr), 4) = brr
    Application.DisplayAlerts = True
End Sub

图不安兔

哥儿- 发表于 2022-8-18 21:13
Sub test()
    Application.DisplayAlerts = False
    Dim arr, brr, i&, j%, n&, num&

谢谢您！哥儿-老师。如果要进步对数据进行去重汇总求和，咋改写代码？（请您随意复制几个放在原数据下面）

哥儿-

图不安兔 发表于 2022-8-19 06:10
谢谢您！哥儿-老师。如果要进步对数据进行去重汇总求和，咋改写代码？（请您随意复制几个放在原数据下面 ...

加个字典去重。
Sub test()
    Application.DisplayAlerts = False
    Dim arr, brr, i&, j%, n&, num&, str$, crr, drr
    Dim dic As Object
    Set dic = CreateObject("scripting.dictionary")
    arr = Sheet1.Range("A1").CurrentRegion
    num = Application.CountA(Sheet1.Range("c2:l" & UBound(arr)))
    Sheet2.[a2:d100000].ClearContents
    ReDim brr(1 To num, 1 To 4)
    For i = 2 To UBound(arr)
        For j = 3 To UBound(arr, 2)
            If arr(i, j) <> "" Then
                n = n + 1
                brr(n, 1) = arr(i, 1)
                brr(n, 2) = arr(i, 2)
                brr(n, 3) = arr(1, j)
                brr(n, 4) = arr(i, j)
                str = brr(n, 1) & "/" & brr(n, 2) & "/" & brr(n, 3)
                dic(str) = dic(str) + brr(n, 4) * 1
            End If
        Next
    Next
    crr = dic.keys
    drr = dic.items
    Erase arr
    ReDim brr(1 To dic.Count, 1 To 4)
    For i = 0 To UBound(crr)
        arr = Split(crr(i), "/")
        brr(i + 1, 1) = arr(0)
        brr(i + 1, 2) = arr(1)
        brr(i + 1, 3) = arr(2)
        brr(i + 1, 4) = drr(i)
    Next
    Sheet2.Range("a2").Resize(UBound(brr), 4) = brr
    Application.DisplayAlerts = True
End Sub