统计同时计数和求和

huangxuejin

各位老师们下午好，我有个不情之请，我今天跟我同学通个电话聊到了我今天得到老师们的帮助受到太大的收益，他是买鲜花的他也想要一个，也叫我请老师们帮帮他，在此我先向老师们拜谢、谢谢谢谢谢谢

joy.008@163.com

简单的数据统计 直接上个透视表就OK了
当然 VBA是万能的
只是感觉杀鸡用牛刀 有点浪费~~~

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, i&, dic As Object
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = [A1].CurrentRegion.Value
    For i = 2 To UBound(ar)
        If Not dic.exists(ar(i, 1)) Then
            dic(ar(i, 1)) = Array(ar(i, 1), 1, ar(i, 2))
        Else
            br = dic(ar(i, 1))
            br(1) = br(1) + 1
            br(2) = br(2) + ar(i, 2)
            dic(ar(i, 1)) = br
        End If
      
    Next i
   
    [D1].CurrentRegion.Offset(1).Clear
    [D2].Resize(dic.Count, 3) = Application.Rept(dic.items, 1)
   
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

参与一下。。。

huangxuejin

joy.008@163.com 发表于 2024-6-14 16:45
简单的数据统计 直接上个透视表就OK了
当然 VBA是万能的
只是感觉杀鸡用牛刀 有点浪费~~~

说的确实是，但对于小白来说一片空白，也想体验新鲜，对吧

huangxuejin

gwjkkkkk 发表于 2024-6-14 17:53
参与一下。。。

谢谢、谢谢、

peteryhr

复习一下字典存入数组
Sub byPeteryhr()
    Dim d As Object, arr, brr(), i&
    Set d = CreateObject("scripting.dictionary")
    arr = Range("a1:b" & Cells(Rows.Count, 1).End(xlUp).Row)
    For i = 2 To UBound(arr)
        If d.exists(arr(i, 1)) Then
            d(arr(i, 1)) = Array(d(arr(i, 1))(0) + 1, d(arr(i, 1))(1) + arr(i, 2))
        Else
            d(arr(i, 1)) = Array(1, arr(i, 2))
        End If
    Next
    ReDim brr(1 To d.Count, 1 To 3)
    For i = 1 To d.Count
        brr(i, 1) = d.Keys()(i - 1)
        brr(i, 2) = d.items()(i - 1)(0)
        brr(i, 3) = d.items()(i - 1)(1)
    Next
    With Sheet1.[d2]
       .NumberFormat = "@"
       .CurrentRegion.Offset(1).ClearContents
        .Resize(UBound(brr), UBound(brr, 2)) = brr
    End With
    Set d = Nothing
    MsgBox "合 计 成 绩 统 计 完 成。"
End Sub