Sub tirage()
Dim tSource, Nsource, tLignes()
Dim dicoTirage, elem, combien&
Dim N&, i&, m&, lequel&, aux&, t0, ech As Boolean
' initialisation
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
t0 = Timer
combien = Range("A_tirer")
Sheets("Feuil1").Activate
If ActiveSheet.AutoFilterMode Then ActiveSheet.Cells.AutoFilter
N = Range("c" & Rows.Count).End(xlUp).Row
If N - 3 < combien Then
MsgBox "Nbr de référence < Nbr à tirer => ECHEC"
Exit Sub
End If
' remplissage du tableau des n° de lignes
tSource = Range("c4.c" & N).Value
Nsource = UBound(tSource)
ReDim tLignes(1 To UBound(tSource))
For i = 1 To UBound(tSource): tLignes(i) = i: Next i
' remplissage aléatoire du dictionnaire sans doublons
Set dicoTirage = CreateObject("scripting.dictionary")
Randomize: m = UBound(tLignes): i = 1
Do
lequel = i + Int(Rnd * m)
aux = tLignes(i): tLignes(i) = tLignes(lequel): tLignes(lequel) = aux
If Not dicoTirage.exists(tSource(tLignes(i), 1)) Then _
dicoTirage.Add tSource(tLignes(i), 1), tLignes(i)
i = i + 1: m = m - 1
Loop Until dicoTirage.Count = combien Or m = 0
'tableau des lignes retenues
ReDim tLignes(1 To UBound(tLignes), 1 To 1)
For Each elem In dicoTirage.keys: tLignes(dicoTirage(elem), 1) = 1: Next elem
' filtre et écriture du résultat
Range("a:a").Insert
Range("a4").Resize(UBound(tLignes)) = tLignes
Range("a3:e" & (Nsource + 1)).AutoFilter Field:=1, Criteria1:="<>"
Sheets("feuil2").Range("a4:d4").Resize(100000).Clear
Range("b3:e" & (UBound(tSource) + 1)).Copy Sheets("feuil2").Range("a3")
Range("a:a").Delete
If ActiveSheet.AutoFilterMode Then ActiveSheet.Cells.AutoFilter
' finalisation
Application.Goto Sheets("feuil2").Range("a1"), True
MsgBox "C'est fini ! ( " & Format(Timer - t0, "0.00") & " sec. )" & vbLf & vbLf & _
Format(dicoTirage.Count, "#,##0") & " enregistrements dictincts tirés au sort."
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
End Sub