Parcourir une plage de cellules de manière aléatoire

Option Explicit
'
' Etablir une référence à Microsoft Scripting Runtime 
' (Outils / Références ...)
'

Sub Test()
Const adrAléa As String = "B2"    '1° cellule recevant les N° aléatoires
Const nbreN° As Integer = 10      'Nombre de N° aléatoires
Dim dicOrdre As Dictionary        'Ordre aléatoire des N°
  
  Set dicOrdre = New Dictionary
  Call OrdreAléatoire(nbreN°, dicOrdre)
  Feuil1.Range(adrAléa).Resize(dicOrdre.Count, 1) = _
      Application.Transpose(dicOrdre.Keys)

End Sub

Private Sub OrdreAléatoire(Quantité As Integer, dicOrdre As Dictionary)
' Renvoi un dictionnaire contenant les numéros de 1 à Quantité
' dans un ordre aléatoire
'
Dim ctr As Integer
Dim aléa As Integer

Randomize
dicOrdre.RemoveAll
For ctr = 1 To Quantité
  aléa = Int(Rnd * Quantité) + 1
  If Not dicOrdre.Exists(aléa) Then
    'si le numèro n'as pas déja été tiré, l'ajouter
    dicOrdre.Add aléa, ctr - 1
  Else
    'sinon réitérer le tirage
    ctr = ctr - 1
  End If
Next

End Sub

derlig = Range("A" & Rows.Count).End(xlUp).Row
ReDim tabl(1 To derlig, 1 To 2)

For i = 1 To derlig
     tabl(i, 1) = i
 Next

 Range("B1:B" & derlig).Value = tabl
 nb = UBound(tabl) + 1

 For i = 1 To nb \ 2
      ou = Int(((nb - i) * Rnd)) + 1
      temp = tabl(ou, 1)
      tabl(ou, 1) = tabl(nb - i, 1)
      tabl(nb - i, 1) = temp
 Next

 Range("B1:B" & derlig).Value = tabl