求按月按人名汇总的数据函数

有大佬会吗 函数 或者宏都行 40多个人
7000多条要疯了

在G3单元格输入下面公式，并向下、向右下拉复制
要求G1至R1单元格格式应设置为日期格式（可输入各月的某一天）
=SUMPRODUCT(($B$2:$B$10000=$F3)*($A$2:$A$10000>EOMONTH(G$2,-1))*($A$2:$A$10000<EOMONTH(G$2,0)+1)*($C$2:$C$10000))

方便给数据吗

透视一下，就出来了

'如果数据量大可以用这方法
Option Explicit
Sub abc()
　Dim a, i, j, p, d, m
　a = [a1].CurrentRegion.Resize(, 3).Value
　ReDim b(10 ^ 4, 12) '
　Set d = CreateObject("scripting.dictionary")
　For i = 2 To UBound(a)
　　p = Month(a(i, 1))
　　If Not d.exists(a(i, 2)) Then m = m + 1: d(a(i, 2)) = m: b(m, 0) = a(i, 2)
　　b(d(a(i, 2)), p) = b(d(a(i, 2)), p) + a(i, 3)
　Next
　For j = 1 To 12
　　b(0, j) = Format(j, "00月")
　Next
　b(0, 0) = "人名"
　With [f1]
　　.Resize(UBound(b) + 1, 12 + 1).Clear
　　With .Resize(m + 1, 12 + 1)
　　　.Borders.LineStyle = xlContinuous
　　　.Value = b
　　End With
　End With
End Sub

公式=SUMPRODUCT((MONTH($A$2:$A$8)=COLUMN(A1))*($B$2:$B$8=$F2)*$C$2:$C$8)
如下图：

Sub text()
Set d = CreateObject("scripting.dictionary")
Dim k, 月份 As Double
arr = UsedRange
For i = 2 To UBound(arr)
g = arr(i, 2): 月份 = Month(arr(i, 1))
If d.exists(g) Then
k = d(g): k(月份) = k(月份) + arr(i, 3)
Else
ReDim k(12): k(0) = g: k(月份) = arr(i, 3)
End If
d(g) = k
Next i
p = d.items
For i = 0 To UBound(p)
Cells(i + 2, 5).Resize(, 13) = p(i)
Next i
End Sub