Option Explicit
Sub TEST()
Dim Brr, Crr, Z, i&, R&, C%, N&, X%, T$, Dx As Date
Set Z = CreateObject("Scripting.Dictionary")
Brr = Range([C2], [A65536].End(xlUp))
ReDim Crr(1000, 1000)
For i = 1 To UBound(Brr)
Dx = Format(Brr(i, 1), "YY/MM/01"): R = Z(Dx)
T = Trim(Brr(i, 2)): C = Z(T)
If R = 0 Then N = N + 1: R = N: Z(Dx) = R: Crr(R, 0) = Dx
If C = 0 Then X = X + 1: C = X: Z(T) = C: Crr(0, C) = T
Crr(R, C) = Crr(R, C) + Brr(i, 3)
Next
T = [E1]: [E:Z].Clear: [E1] = T: [E1].HorizontalAlignment = xlCenter
With [E1].Resize(1, X + 2): .Merge: .Borders.LineStyle = 1: End With
If N * X = 0 Then Exit Sub
With [E2].Resize(N + 1, X + 2)
.Value = Crr
.Offset(0, 1).Sort KEY1:=.Item(1), Order1:=1, Header:=2, Orientation:=2
.Offset(1, 0).Sort KEY1:=.Item(1), Order1:=1, Header:=2, Orientation:=1
.Columns(1).NumberFormatLocal = "m""月"""
.Borders.LineStyle = 1
.Columns(X + 2) = "=SUM(F2:" & Cells(2, X + 5).Address(0, 0) & ")"
.Cells(1, 1) = "種類": .Cells(1, X + 2) = "總計"
End With
End Sub
