Option Explicit
Sub TEST()
Dim Brr, Crr(1 To 100, 1 To 3), i&, j&, k&, TT, T(1 To 4), Y, A, D$
Set Y = CreateObject("Scripting.Dictionary")
Brr = Range([原始資料!D2], [原始資料!A65536].End(3))
For i = 1 To UBound(Brr)
For k = 1 To 4: T(k) = Brr(i, k): TT = TT & "|" & T(k): Next
If Y(TT) <> "" Or T(1) = "" Then GoTo i01
A = Y(T(1) & "/a")
If Not IsArray(A) Then A = Crr
D = T(1): Y(D) = Y(D) + 1
For j = 1 To 3: A(Y(D), j) = T(j + 1): Next
Y(T(1) & "/a") = A: Y(TT) = 1: TT = ""
i01:
Next
With Sheets("SHEET2")
.UsedRange.Offset(2, 0).ClearContents
For i = 1 To 13 Step 3
D = .Cells(1, i): .Cells(3, i).Resize(Y(D), 3) = Y(D & "/a")
Next
Application.Goto .[A1]
End With
Set Y = Nothing: Erase Brr, Crr, T, A
End Sub
發表於 2023-3-14 15:05
| 
