option explicit option base 1 Sub 分类汇总() Dim ws0 As Worksheet, ws1 As Worksheet Dim arr0 As Variant, arr1 As Variant Dim lastRow As Long, i As Long, m As Long, cnt As Long Dim acct As String, opp As String, key As String, pts() As String Dim amt As Double, tmp As Variant Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary") Set ws0 = Sheets("交易数据") Set ws1 = Sheets("汇总结果") lastRow = ws0.Cells(ws0.Rows.Count, 1).End(xlUp).Row ' 一次性读入数组 arr0 = ws0.Range("A1:D" & lastRow).Value For i = 2 To lastRow acct = arr0(i, 1) opp = arr0(i, 2) amt = arr0(i, 3) key = acct & "|" & opp If Not dict.Exists(key) Then dict(key) = Array(0, 0, 0, 0, 0, 0, 0, "") End If tmp = dict(key) tmp(0) = tmp(0) + 1 If amt < 0 Then tmp(1) = tmp(1) + 1 tmp(4) = tmp(4) + amt Else tmp(2) = tmp(2) + 1 tmp(5) = tmp(5) + amt End If tmp(3) = tmp(3) + amt If amt Mod 100 = 0 Then tmp(6) = tmp(6) + 1 If tmp(7) = "" Or arr0(i, 4) > tmp(7) Then tmp(7) = arr0(i, 4) End If dict(key) = tmp Next i ' 输出 ws1.Cells.Clear cnt = dict.Count ReDim arr1(1 To cnt, 1 To 10) m = 1 For Each key In dict.Keys pts = Split(key, "|") tmp = dict(key) arr1(m, 1) = pts(0) arr1(m, 2) = pts(1) arr1(m, 3) = tmp(0) arr1(m, 4) = tmp(1) arr1(m, 5) = tmp(2) arr1(m, 6) = tmp(3) arr1(m, 7) = tmp(4) arr1(m, 8) = tmp(5) arr1(m, 9) = tmp(6) arr1(m, 10) = tmp(7) m = m + 1 Next ws1.Range("A1:J1") = Array("账户名", "对手名", "交易总次数", "转出总次数", _ "转入总次数", "累计金额", "转出总金额", "转入总金额", _ "整百金额次数", "最后一次转账时间") If cnt > 0 Then ws1.Range("A2:J" & 1 + cnt) = arr1 ws1.Columns.AutoFit MsgBox "汇总完成！" End Sub
