Sub TIRAGE()
Dim i&, j&, n&, u&, x()
Dim a As New Scripting.Dictionary
Const k& = 2
With Feuille1
For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
With .Cells(i, 1)
If Not IsEmpty(.Value) Then
If Not a.Exists(.Value) Then
a.Add .Value, .Offset(, 1).Value
n = n + 1
End If
End If
End With
Next
End With
ReDim x(1 To n \ k + 1, 2 * k)
Randomize
For i = 1 To n \ k: For j = 0 To 2 * k - 2 Step 2
u = Int(n * Rnd)
x(i, j) = a.Keys(u): x(i, j + 1) = a.Items(u)
a.Remove x(i, j)
n = n - 1
Next j, i
For j = 0 To n - 1
x(i, 2 * j) = a.Keys(0): x(i, 2 * j + 1) = a.Items(0)
a.Remove x(i, 2 * j)
Next
With Worksheets("Tirage").[B2]
.CurrentRegion.Offset(1).ClearContents
.Resize(i, 2 * k).Value = x
.Parent.Activate
End With
End Sub