统计同时计数和求和

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

wang-way

sdytsxd991122 发表于 2024-6-14 09:09
wps

大佬 你这数组使用得出神入化

Qs18

Sub test()
Dim Sql$
Application.ScreenUpdating = False
Set cnn = CreateObject("adodb.connection")
Set rst = CreateObject("ADODB.RecordSet")
With Sheet1
    Dim rw: rw = .Cells(Rows.Count, 2).End(xlUp).Row
    With cnn
        .Open "Provider=Microsoft.Ace.oledb.12.0;extended properties='excel 12.0;HDR=yes';data source=" & ThisWorkbook.FullName
        Sql = "select 姓名,COUNT(*) as 借支次数 ,sum(借支金额) as 借支总金额 from [Sheet1$a1:b" & rw & "] group by 姓名"
    End With
    rst.Open Sql, cnn, 1, 3
    .Range("d2:f10000").ClearContents
    .Range("d2").CopyFromRecordset rst
End With
rst.Close
cnn.Close
Set cnn = Nothing
Set rst = Nothing
MsgBox "完成！"
End Sub

Qs18

换一个方式用SQL试一下