Option Explicit
Sub TEST_20221220()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim Arr, i&, j&, T1$, T3&, T6$, W, X, Y, Z, C, R, m, N, S
Set X = CreateObject("Scripting.Dictionary")
Set Y = CreateObject("Scripting.Dictionary")
Set W = CreateObject("Scripting.Dictionary")
Arr = Range([eb!F2], [eb!A1].Cells(Rows.Count, 1).End(xlUp))
For i = 1 To UBound(Arr)
If W(Arr(i, 1)) = Empty Then
S = S + 1
W(Arr(i, 1)) = S
Arr(i, 2) = S
Else
Arr(i, 2) = W(Arr(i, 1))
End If
Next
With Sheets.Add
With .[A1].Resize(UBound(Arr), UBound(Arr, 2))
.Value = Arr
.Sort _
KEY1:=.Item(2), Order1:=xlAscending, _
Key2:=.Item(6), Order2:=xlAscending, _
Header:=xlNo, Orientation:=xlTopToBottom
Arr = .Value
End With
.Delete
End With
For i = 1 To UBound(Arr)
T1 = Arr(i, 1)
T3 = Arr(i, 3)
T6 = Arr(i, 6)
If X(T1 & "|" & T6) = Empty Then
Y(T1) = Y(T1) + 1
X(T1 & "|" & T6) = Y(T1)
If Y(T1) > m Then m = Y(T1)
End If
W(T1 & "|" & T6) = W(T1 & "|" & T6) + T3
Next
ReDim Arr(1 To Y.Count, 1 To m + 3)
For Each R In Y.KEYS
N = N + 1
Arr(N, 1) = "'" & R
Y(R) = N
Next
For Each C In X.KEYS
Arr(Y(Split(C, "|")(0)), X(C) + 3) = Split(C, "|")(1) & "/" & W(C)
Next
Sheets("List").UsedRange.Offset(1, 0).Clear
With [List!A2].Resize(UBound(Arr), UBound(Arr, 2))
.Value = Arr
End With
Set X = Nothing
Set Y = Nothing
Set Z = Nothing
Set Arr = Nothing
End Sub作者: jsc0518 時間: 2022-12-20 20:06
