Option Explicit
Sub AJA()
Dim a&, Tc&(), r&, i&, Th$(), b&, Tr$(), c&, d As Boolean, Rg As Range, e%, Rep&
Rep = Cells(2, 3)
r = Cells(Rows.Count, 2).End(xlUp).Row
If r < 3 Then Exit Sub
Refaire:
ReDim Tc(1 To 1): a = 1: Tc(a) = 1: ReDim Th(1 To 2, 1 To r - 1): Th(1, 1) = Cells(2, 1): Th(2, 1) = Cells(2, 2)
For i = 3 To r
If Cells(i, 2) <> Cells(i - 1, 2) Then
a = a + 1: ReDim Preserve Tc(1 To a): Tc(a) = 1
Else
Tc(a) = Tc(a) + 1
End If
Th(1, i - 1) = Cells(i, 1): Th(2, i - 1) = Cells(i, 2)
Next i
Randomize
Do
e = 0
Do
e = e + 1
b = Int(UBound(Th, 2) * Rnd) + 1
If c >= 2 Then
d = False
For i = 0 To Rep - 2
If Th(2, b) <> Tr(2, c - i) Then d = True: Exit For
Next i
End If
If e > r Then GoTo Refaire
Loop Until c < Rep Or d
c = c + 1: ReDim Preserve Tr(1 To 2, 1 To c)
Tr(1, c) = Th(1, b): Tr(2, c) = Th(2, b)
If c = r - 1 Then Exit Do
For i = b To UBound(Th, 2) - 1
Th(1, i) = Th(1, i + 1): Th(2, i) = Th(2, i + 1)
Next i
ReDim Preserve Th(1 To 2, 1 To UBound(Th, 2) - 1)
a = 0
For i = 1 To UBound(Tc)
If b > Tc(i) + a Then a = a + Tc(i) Else Tc(i) = Tc(i) - 1: Exit For
Next i
Loop Until c = r - 1
For i = 1 To UBound(Tr, 2)
Cells(i + 1, 4) = Tr(1, i)
Next i
End Sub