tirage aléatoire

Sub TirageAleat()
Dim t, i&, j&, n&, aux, t0
   t0 = Timer: t = [a1].ListObject.DataBodyRange: ReDim r(1 To UBound(t) + 1, 1 To 3): Randomize
   For i = 1 To UBound(t): n = 1 + Int(Rnd * UBound(t)): aux = t(i, 1): t(i, 1) = t(n, 1): t(n, 1) = aux: Next i
   For i = 1 To UBound(t): n = Asc(Left(t(i, 1), 1)) - 64: r(UBound(t) + 1, n) = r(UBound(t) + 1, n) + 1: r(r(UBound(t) + 1, n), n) = t(i, 1): Next i
   Range("c2").Resize(UBound(t), 3) = r
   MsgBox Format(Timer - t0, "0.000 \sec.")
End Sub

Option Explicit
               #If VBA7 Then
Private Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" (X As Currency) As Boolean
Private Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" (X As Currency) As Boolean
               #Else
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (X As Currency) As Boolean
Private Declare Function QueryPerformanceCounter Lib "kernel32" (X As Currency) As Boolean
                  #End If
Private PerfoCtrDép As Currency
Sub DépartChrono()
   QueryPerformanceCounter PerfoCtrDép
   End Sub
Function SecondesChrono() As Double
   Dim PerfoCtrAct As Currency, Freq As Currency
   QueryPerformanceCounter PerfoCtrAct
   QueryPerformanceFrequency Freq
   SecondesChrono = (PerfoCtrAct - PerfoCtrDép) / Freq
   End Function
Sub Test()
   Application.Wait Now + TimeSerial(0, 0, 1)
   DépartChrono
   Application.Wait Now + TimeSerial(0, 0, 1)
   MsgBox SecondesChrono
   End Sub

Option Compare Text 'la casse est ignorée

Private Sub Worksheet_Activate()
Dim c As Range, x$, crit$, n&, i&, a(), b
Randomize
Application.ScreenUpdating = False
With [Tableau1].ListObject.Range 'tableau structuré
    .Sort .Columns(1), xlAscending, Header:=xlYes 'tri du tableau
    For Each c In UsedRange
        If c = "N° Equipe" Then
            x = Trim(Replace(c(0, 0), "POULE", ""))
            crit = x & "*"
            n = Application.CountIf(.Columns(1), crit)
            c(2).Resize(4, 2) = "" 'RAZ
            If x <> "" And n Then
                ReDim a(1 To n)
                For i = 1 To n: a(i) = Rnd: Next i 'nombres aléatoires
                b = .Cells(Application.Match(crit, .Columns(1), 0), 1).Resize(n, 2) 'au moins 2 éléments
                tri a, b, 1, n
                With c(2).Resize(4)
                    .Value = b 'restitution
                    .Replace x, "", xlPart
                End With
            End If
        End If
    Next
End With
End Sub

Sub tri(a, b, gauc, droi) ' Quick sort
Dim ref, g, d, temp
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      temp = b(g, 1): b(g, 1) = b(d, 1): b(d, 1) = temp
      g = g + 1: d = d - 1
    End If
Loop While g <= d
If g < droi Then Call tri(a, b, g, droi)
If gauc < d Then Call tri(a, b, gauc, d)
End Sub