'假设c列有序,最多支持20个不同项目,,,
Option Explicit
Sub test()
Dim arr, i, m, n, dic
Set dic = CreateObject("scripting.dictionary")
arr = [a1].CurrentRegion.Offset(1)
ReDim brr(1 To UBound(arr, 1), 1 To 20 + 3) As String
m = 1: n = 3
For i = 2 To UBound(arr, 1) - 1
If Not dic.exists(arr(i, 4)) Then n = n + 1: dic(arr(i, 4)) = n
brr(m, dic(arr(i, 4))) = arr(i, 5)
If arr(i, 2) <> arr(i + 1, 2) Then
brr(m, 1) = m: brr(m, 2) = arr(i, 2): brr(m, 3) = arr(i, 3): m = m + 1
End If
Next
With [g3]
.Resize(Rows.Count - 2, n + 1).ClearContents
.Resize(m, n) = brr
End With
End Sub |