统计数量和计算金额合计

xing_chen

老师！有表，我希望能对名称列的中相同单元格计算数量，并计算器金额合计，在其后删除相同单元格的行。敬请老师赐教。谢谢！

shiruiqiang

xing_chen

shiruiqiang 发表于 2023-3-11 21:55

谢谢老师！运行顺利。若我只想对指定字符进项统计和金额合计，有如何？再请老师赐教

xing_chen

xing_chen 发表于 2023-3-11 22:24
谢谢老师！运行顺利。若我只想对指定字符进项统计和金额合计，有如何？再请老师赐教

代码修改，出问题，敬请老师赐教：
Sub test()
    Dim arr, brr
    Dim dic1, dic2
    n = 1
    Set dic1 = CreateObject("scripting.dictionary")
    Set dic2 = CreateObject("scripting.dictionary")
    Range("h2:l10000").ClearContents
    arr = [a1].CurrentRegion
    ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    For x = 2 To UBound(arr)
        dic1(arr(x, 2)) = dic1(arr(x, 2)) + 1
        dic2(arr(x, 2)) = dic2(arr(x, 2)) + Val(arr(x, 4))
    Next

    For Each k In dic1.keys
        n = n + 1
        If dic1("华为") = 1 Then
            Cells(n, "i") = "华为"
        Else
            Cells(n, "i") = "华为" & "(" & dic1("华为") & "笔)"
        End If
        Cells(n, "华为") = dic2("华为")
    Next
End Sub

xing_chen

修改了代码，怎么到现在还没有显现在网上呀

杨建营

请楼主参考。

杨建营

附件在审核。

lushang2018

1.     arr = Sheet1.Range("A1:D" & Sheet1.Cells(Rows.Count, "B").End(xlUp).Row)
   
2.     ReDim brr(1 To 3)
   
3.     For i = 2 To UBound(arr)
   
4.         key = arr(i, 2)
   
5.         If Not dic.Exists(key) Then
   
6.             k = 1
   
7.             brr(1) = arr(i, 2)
   
8.             brr(3) = arr(i, 4)
   
9.             dic(key) = brr
   
10.         Else
    
11.             brr = dic(key)
    
12.             k = k + 1
    
13.             brr(1) = arr(i, 2) & "(" & k & "笔)"
    
14.             brr(3) = brr(3) + arr(i, 4)
    
15.             dic(key) = brr
    
16.         End If
    
17.     Next
    
18.     keys = dic.keys
    
19.     ReDim crr(1 To dic.Count, 1 To 3)
    
20.     For i = LBound(keys) To UBound(keys)
    
21.         key = keys(i)
    
22.         brr = dic(key)
    
23.         For j = 1 To 3
    
24.             crr(i + 1, j) = brr(j)
    
25.         Next
    
26.     Next
    
27.     Sheet1.Range("I8").Resize(UBound(crr), UBound(crr, 2)) = crr
    

复制代码

lushang2018

Sub 测试()  ''答题专用套路--by:学习使我快乐
    Dim i, j, k, m, n, arr, brr, crr, drr
    Dim sht As Worksheet, wbk As Workbook, rng As Range
    Dim dic As Object, key As String, keys, items
    Set dic = CreateObject("scripting.dictionary")
    arr = Sheet1.Range("A1:D" & Sheet1.Cells(Rows.Count, "B").End(xlUp).Row)
    ReDim brr(1 To 3)
    For i = 2 To UBound(arr)
        key = arr(i, 2)
        If Not dic.Exists(key) Then
            k = 1
            brr(1) = arr(i, 2)
            brr(3) = arr(i, 4)
            dic(key) = brr
        Else
            brr = dic(key)
            k = k + 1
            brr(1) = arr(i, 2) & "(" & k & "笔)"
            brr(3) = brr(3) + arr(i, 4)
            dic(key) = brr
        End If
    Next
    keys = dic.keys
    ReDim crr(1 To dic.Count, 1 To 3)
    For i = LBound(keys) To UBound(keys)
        key = keys(i)
        brr = dic(key)
        For j = 1 To 3
            crr(i + 1, j) = brr(j)
        Next
    Next
    Sheet1.Range("I8").Resize(UBound(crr), UBound(crr, 2)) = crr
End Sub

shiruiqiang

xing_chen 发表于 2023-3-11 22:24
谢谢老师！运行顺利。若我只想对指定字符进项统计和金额合计，有如何？再请老师赐教

字典有了，直接输出就行