Supprimer aléatoirement des valeurs

Sub Sup30Col()
    Dim a() As Byte, c%, r&, b&, d&, f&, i&
    c = ActiveCell.Column: r = Cells(Rows.Count, c).End(xlUp).Row: ReDim a(1 To r): f = Round(0.3 * r): Randomize
    Do
        d = Int(r * Rnd) + 1
        If a(d) = 0 Then a(d) = 1: b = b + 1
    Loop Until b = f
    Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
    For i = r To 1 Step -1
        If a(i) = 1 Then Cells(i, c).Delete Shift:=xlUp
    Next i
    Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic: Cells(1, c).Select
End Sub