Option Explicit
Sub TEST()
Dim Brr, Crr, A(2), Y, Z, N&, i&, j&, xR As Range, Sh As Worksheet
Set Y = CreateObject("Scripting.Dictionary")
Set Sh = Sheets("sheet2"): Set xR = Sh.UsedRange.Offset(1, 0): Brr = xR
For i = 0 To UBound(A)
A(i) = Intersect(xR, [A:H].Offset(0, i * 8))
For j = 1 To UBound(A(i))
Y(A(i)(j, 2)) = Y(A(i)(j, 2)) + 1: Y(A(i)(j, 2) & "|" & i) = j
Next
Next
For Each Z In Y.keys
If Y(Z) = UBound(A) + 1 And InStr(Z, "|") = 0 And Z <> "" Then
N = N + 1
For i = 0 To UBound(A)
For j = 1 To 8
Brr(N, j + 8 * i) = Brr(Y(Z & "|" & i), j + 8 * i)
Next
Next
End If
Next
xR.ClearContents
[A2].Resize(N, 8 * (UBound(A) + 1)) = Brr
Set Y = Nothing: Set xR = Nothing: Set Sh = Nothing: Erase A, Brr
End Sub
發表於 2023-4-11 10:27
| 
