Option Explicit
Sub test()
Dim arr, dic(1), i, j, m, n, t
For i = 0 To UBound(dic)
Set dic(i) = CreateObject("scripting.dictionary")
Next
arr = [a1].CurrentRegion
ReDim brr(UBound(arr, 1), 12)
For i = 2 To UBound(arr, 1)
t = Split(arr(i, 2))(0)
If Not dic(0).exists(t) Then m = m + 1: dic(0)(t) = m: brr(m, 0) = t
For j = 4 To UBound(arr, 2)
If Not dic(1).exists(arr(1, j)) Then n = n + 1: dic(1)(arr(1, j)) = n: brr(0, n) = arr(1, j)
brr(dic(0)(t), dic(1)(arr(1, j))) = brr(dic(0)(t), dic(1)(arr(1, j))) + arr(i, j)
Next
Next
brr(0, 0) = "品名"
[a21].Resize(m + 1, n + 1) = brr
End Sub |