汇总

ddz79101

huarong7984 发表于 2024-4-16 08:39
所发示例，可自主选择汇总的代码位数，仅供参考

谢谢老师！运行成功

zhangcheng6688

chxw68 发表于 2024-4-15 20:22
修改好了。

Sub test()
    Dim r%, i%
    Dim arr, brr
    Dim d As Object
    Set d = CreateObject("scripting.dictionary")
    With Worksheets("K本费")
        r = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Range("a2:i" & r)
        For i = 1 To UBound(arr)
            xm = Left(arr(i, 5), 4)
            If Not d.exists(xm) Then
                ReDim brr(1 To 4)
                brr(1) = xm
            Else
                brr = d(xm)
            End If
            For j = 2 To 4
                brr(j) = brr(j) + arr(i, j + 5)
            Next
            d(xm) = brr
        Next
        .Range("p2").Resize(d.Count, 4) = Application.Transpose(Application.Transpose(d.items))
    End With
End Sub

Qs18

Sub text()
        Dim arr
        Dim i As Long
        Dim sht As Worksheet
        Dim dic As New Dictionary
        Set sht = Sheets("K本费")
    With sht
        arr = sht.Range("a1").CurrentRegion.Value
        For i = 2 To UBound(arr)
          s = Left(arr(i, 5), 4)
          If dic.Exists(s) Then
            dic(s) = dic(s) + arr(i, 7)
            Else
            dic(s) = arr(i, 7)
          End If
        Next
        .Range("p2").Resize(dic.Count, 2) = Application.Transpose(Array(dic.Keys, dic.Items))
    End With
End Sub