tirage aléatoire par personne

Sub Tirage()
Dim nlig&, d As Object, c As Range, i&, c1 As Range
Application.ScreenUpdating = False
With ActiveSheet.UsedRange.EntireRow
  nlig = .Rows.Count
  .Columns("G").ClearContents 'RAZ
  Set d = CreateObject("Scripting.Dictionary")
  Randomize
  For Each c In .Columns("F").Cells
    i = Application.CountIf(.Columns("C"), c)
    For i = 1 To IIf(i < 4, i, 4)
      Do
        Set c1 = .Cells(Int(1 + nlig * Rnd), "D")
      Loop While c1(1, 0) <> c Or d.exists(c1.Value)
      d(c1.Value) = ""
      c(i, 2) = c1
    Next
  Next
End With
End Sub

Sub Tirage()
Dim deb As Range, P As Range, nlig&, d As Object
Dim c As Range, i&, c1 As Range
Set deb = [F4]
Set P = Range("C4", Range("C" & Rows.Count).End(xlUp)(2))
nlig = P.Rows.Count
Application.ScreenUpdating = False
Randomize
deb.Resize(Rows.Count - deb.Row + 1, 2).ClearContents 'RAZ
Set d = CreateObject("Scripting.Dictionary")
For Each c In P
  If c <> "" And Not d.exists(c.Value) Then
    d(c.Value) = ""
    deb = c
    i = Application.CountIf(P, c)
    For i = 1 To IIf(i < 4, i, 4)
      Do
        Set c1 = P(Int(1 + nlig * Rnd), 2)
      Loop While c1(1, 0) <> c Or d.exists(c1.Value)
      d(c1.Value) = ""
      deb(i, 2) = c1
    Next
    Set deb = deb(5)
  End If
Next
End Sub

Sub Tirage()
Dim deb As Range, P As Range, nlig&, d As Object
Dim c As Range, d1 As Object, c1 As Range, i As Byte
Set deb = [F4]
Set P = Range("C4", Range("C" & Rows.Count).End(xlUp)(2))
nlig = P.Rows.Count
Application.ScreenUpdating = False
Randomize
deb.Resize(Rows.Count - deb.Row + 1, 2).ClearContents 'RAZ
Set d = CreateObject("Scripting.Dictionary")
For Each c In P
  If c <> "" And Not d.exists(c.Value) Then
    d(c.Value) = ""
    deb = c
    Set d1 = CreateObject("Scripting.Dictionary")
    For Each c1 In P.Offset(, 1)
       If c1(1, 0) = c Then If Not d1.exists(c1.Value) Then d1(c1.Value) = ""
    Next
    For i = 1 To IIf(d1.Count < 4, d1.Count, 4)
      Do
        Set c1 = P(Int(1 + nlig * Rnd), 2)
      Loop While c1(1, 0) <> c Or d.exists(c1.Value)
      d(c1.Value) = ""
      deb(i, 2) = c1
    Next
    Set deb = deb(5) 'deb(i)
  End If
Next
End Sub

Sub Tirage()
Dim deb As Range, P As Range, d As Object, c As Range
Dim d1 As Object, c1 As Range, a, n&, i As Byte, x
Set deb = [F4]
Set P = Range("C4", Range("C" & Rows.Count).End(xlUp)(2))
Application.ScreenUpdating = False
Randomize
deb.Resize(Rows.Count - deb.Row + 1, 2).ClearContents 'RAZ
Set d = CreateObject("Scripting.Dictionary")
For Each c In P
  If c <> "" And Not d.exists(c.Value) Then
    d(c.Value) = ""
    deb = c
    Set d1 = CreateObject("Scripting.Dictionary")
    For Each c1 In P.Offset(, 1)
      If c1(1, 0) = c Then If Not d1.exists(c1.Value) Then d1(c1.Value) = ""
    Next
    a = d1.keys: n = d1.Count: d1.RemoveAll
    For i = 1 To IIf(n < 4, n, 4)
      Do
        x = a(Int(n * Rnd))
      Loop While d1.exists(x)
      d1(x) = ""
      deb(i, 2) = x
    Next
    Set deb = deb(5) 'deb(i)
  End If
Next
End Sub

Sub Tirage()
Dim ntirage, deb As Range, t, nlig&, d As Object, i&, x, a, h&, rest(), j&, b, n&
ntirage = 4 'paramétrable
Set deb = [F4]
t = Range("C4:D" & Range("C" & Rows.Count).End(xlUp)(2).Row) 'matrice
nlig = UBound(t)
Set d = CreateObject("Scripting.Dictionary")
'---noms sans doublons---
For i = 1 To nlig
  x = t(i, 1)
  If x <> "" Then d(x) = ""
Next i
If d.Count = 0 Then GoTo 1
'---tirage des ID---
a = d.keys: h = ntirage * d.Count
ReDim rest(1 To h, 1 To 2)
Randomize
For i = 0 To UBound(a)
  x = a(i)
  rest(ntirage * i + 1, 1) = x
  d.RemoveAll
  For j = 1 To nlig
    If t(j, 1) = x Then d(t(j, 2)) = ""
  Next j
  b = d.keys: n = d.Count: d.RemoveAll
  For j = 1 To IIf(n < ntirage, n, ntirage)
    Do
      x = b(Int(n * Rnd))
    Loop While d.exists(x)
    d(x) = ""
    rest(ntirage * i + j, 2) = x
  Next j
Next i
'---restitution---
deb.Resize(h, 2) = rest
1 deb.Offset(h).Resize(Rows.Count - deb.Row - h + 1, 2).ClearContents
End Sub