Tirage sur un colonne sans doublons (grd base données )

ActiveSheet.Range("$C$1:$P$799").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, _
        7, 8, 9, 10, 11, 12, 13, 14), Header:=xlYes

Sub TiragesAléatoires()
Dim n&, derlig&, P As Range
n = 300 '1000 'nombre de lignes à retenir, à adapter
Application.ScreenUpdating = False
derlig = ActiveSheet.Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row
With Feuil2 'CodeName de la feuille de restitution
  .Rows("4:" & .Rows.Count).Delete 'RAZ
  ActiveSheet.Rows("4:" & derlig).Copy .[A4]
  Set P = Intersect(.UsedRange, .Rows("4:" & derlig))
  With P.Columns(P.Columns.Count + 1) 'colonne auxiliaire à droite
    .Formula = "=RAND()"
    .Value = .Value 'supprime les formules
    .Cells(1) = 0
    Union(P, .Cells).Sort .Cells, xlAscending 'tri
    .EntireColumn.Delete 'suppression de la colonne auxiliaire
  End With
  .Rows(n + 5 & ":" & .Rows.Count).Delete
  n = .UsedRange.Rows.Count 'ajuste la barre de défilement verticale
  .Columns.AutoFit 'ajustement de la largeur des colonnes
  .Activate
End With
End Sub

Sub test()
a
MsgBox "pause"
a "B2:J13,L2:P13"
End Sub

Private Sub a(Optional vide$ = "Z1")
[A1] = "ITEM1": [A1].AutoFill Destination:=Range("A1:P1"), Type:=xlFillDefault
With Range("A2:A13")
    .Value = Application.Transpose(Array(1, 2, 3, 4, 4, 4, 4, 6, 7, 8, 9, 10))
    .AutoFill Destination:=Range("A2:P13"), Type:=xlFillDefault
End With
Range(vide) = Empty
MsgBox "Test RemoveDuplicates"
ActiveSheet.Range("$A$1:$P$13").RemoveDuplicates Columns:=11, Header:=xlYes
End Sub

P.RemoveDuplicates Columns:=11, Header:=xlYes

Sub Echantillon2()
    Dim r&, a$(), p#, i&, c&, b&, d%, w As Worksheet, e%, j%, n&
    Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
    Worksheets("BDD").Activate
    b = 4: d = 11: n = 300                               'ligne de titres/colonne sans éléments vides/nb de dossiers demandés
    r = Cells(Rows.Count, d).End(xlUp).Row - b
    e = Cells(b, Columns.Count).End(xlToLeft).Column     'pas d'intitulés de colonnes vides
    If n > r Then Exit Sub
    ReDim a(1 To n, 1 To e): p = n / r: Randomize
    For i = 1 To r - 1
        If Not Rnd > p Then
            c = c + 1: n = n - 1
            For j = 1 To e: a(c, j) = Cells(i + b, j): Next j
        End If
        p = n / (r - i)
    Next i
    If n = 1 Then a(UBound(a)) = r
    Set w = ActiveSheet: Sheets.Add: w.Cells.Copy Destination:=[A1]
    Range(Cells(b + 1, 1), Cells(Rows.Count, Columns.Count)).ClearContents
    Cells(b + 1, 1).Resize(UBound(a), e) = a
    Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
End Sub

Sub AjoutRéfScripting()
ActiveWorkbook.VBProject.References.AddFromFile "C:\WINDOWS\System32\scrrun.dll"
End Sub