Option Explicit
Sub TEST_20230106_1()
Dim Brr, i&, x, Y, j&, Lac&
Set Y = CreateObject("Scripting.Dictionary")
Lac = Cells.SpecialCells(xlLastCell).Row
Brr = Range([A2], Cells(Lac, "E"))
For j = 1 To 5
If j = 2 Then GoTo Spa
Set Y(j) = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Brr)
If Brr(i, j) = "" Then GoTo Spa
Y(j)(Brr(i, j)) = i
Next
Spa:
Next
ReDim Brr(1 To Y(1).Count, 1 To 3)
For Each x In Y(1).KEYS
If Y(3)(x) & Y(4)(x) & Y(5)(x) = "" Then
Y("G") = Y("G") + 1
Brr(Y("G"), 1) = x
ElseIf Y(3)(x) > 0 And Y(5)(x) = "" Then
Y("H") = Y("H") + 1
Brr(Y("H"), 2) = x
ElseIf Y(4)(x) > 0 Then
Y("I") = Y("I") + 1
Brr(Y("I"), 3) = x
End If
Next
Range([G2], Cells(Lac, "I")).ClearContents
[G2].Resize(UBound(Brr), 3) = Brr
Set Y = Nothing
End Sub
發表於 2023-1-6 14:40
| 