then let's try this
Sub ertert()
Dim x, y, i&, j&, s$
Application.ScreenUpdating = False
y = Range("L1:M" & Cells(Rows.Count, 12).End(xlUp).Row).Value

With Range("F2:K" & Cells(Rows.Count, 6).End(xlUp).Row)
    .Columns(6).FormulaR1C1 = "=RANDBETWEEN(1," & .Rows.Count & ")"
    .Sort Key1:=.Cells(1, 6), Order1:=xlAscending
    x = .Value
    .Columns(6).ClearContents
    .Sort Key1:=.Cells(1, 5), Order1:=xlAscending, Key2:=.Cells(1, 1), Order2:=xlAscending
End With

With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 1 To UBound(y)
        .Item(y(i, 2) & "~" & y(i, 1)) = Empty
    Next i

    For i = 1 To UBound(x)
        s = x(i, 1) & "~" & x(i, 5)
        If Not .exists(s) Then
            .Item(s) = Empty
            If .exists(x(i, 5)) Then
                .Item(x(i, 5)) = .Item(x(i, 5)) + 1
                If .Item(x(i, 5)) < 3 Then j = j + 1: x(j, 2) = x(i, 1): x(j, 1) = x(i, 5)
            Else
                j = j + 1: x(j, 2) = x(i, 1): x(j, 1) = x(i, 5)
                .Item(x(i, 5)) = 1
            End If
        End If
    Next i
End With

If j > 0 Then
    [L:M].ClearContents: [L1:M1].Resize(UBound(y)).Value = y
    With Cells(Rows.Count, 12).End(xlUp)(2).Resize(j, 2)
        .Value = x
        .Sort Key1:=.Cells(1, 1), Order1:=xlAscending
    End With
Else
    MsgBox "That's all, no more records", 64
End If
Application.ScreenUpdating = True
End Sub