Option Explicit
Sub TEST()
Dim Brr, Crr(1 To 1000, 1 To 3), V, Z, i&, R&, N&, T$
'↑宣告變數
Set Z = CreateObject("Scripting.Dictionary")
'↑令Z變數是 字典
Brr = Range([D2], [B65536].End(3))
'↑令Brr變數是 二維陣列,以B~D欄儲存格值帶入陣列中
With [G2].Resize(UBound(Brr), 3)
'↑以下是關於[G2]擴展向下Brr陣列縱向最大索引列號,向右擴展3欄範圍儲存格的程序
.Value = Brr
'↑令該區域儲存格值是 Brr陣列值
.Sort KEY1:=.Item(3), Order1:=2, Header:=2, _
Key2:=.Item(1), Order2:=1, Header:=2, Orientation:=1
'↑令該區域儲存格做排序
Brr = .Value: .ClearContents: .Offset(0, 5).ClearContents
'↑令Brr陣列換裝盛排序過後的該區域儲存格值,
'令結果區域儲存格清除內容
End With
For i = 1 To UBound(Brr)
'↑設順迴圈
T = Brr(i, 3): V = Z(T)
'↑令T變數是第1欄陣列值,V變數是T變數查Z字典的item
If Not IsArray(V) Then V = Crr
'↑如果V變數不是陣列? True就令V變數是Crr陣列
R = Z(T & "|r") + 1: Z(T & "|r") = R
'↑令R變數是T變數連接"|r"組成的新字串查Z字典item值+1,
'令T變數連接"|r"組成的字串在Z字典的key,所對應的item是 R變數
V(R, 1) = R: V(R, 2) = Brr(i, 1): V(R, 3) = Brr(i, 2)
'↑令V陣列依序寫入值
Z(T) = V
'↑令V陣列放回Z字典中
Next
For Each V In Z.KEYS
'↑設逐項迴圈!令V變數是Z字典的key
If Not IsArray(Z(V)) Then GoTo i01
'↑如果以V變數查Z字典回傳item不是陣列? True就跳到標示i01位置繼續執行
Cells(2, 7 + N * 5).Resize(Z(V & "|r"), 3) = Z(V)
'↑令字典中的陣列item寫入儲存格中
N = N + 1
'↑令N變數累加1
i01: Next
Set Z = Nothing: Erase Brr, Crr
End Sub
