Sub RandomSort()
  Dim TitleCell As Range, Rng As Range, Tmp As Range, i&
  Const Debugging = False     ' <-- Для отладки
  Set TitleCell = Лист1.[A3]  ' <-- Менять здесь: заголовок ФИО
  ' Задать диапазон данных с дополнительной колонкой справа
  Set Rng = TitleCell.CurrentRegion
  i = TitleCell.Row - Rng.Row
  If i >  0  Then Set Rng = Rng.Resize(Rng.Rows.Count - i).Offset(i)
  Set Rng = Rng.Resize(, Rng.Columns.Count +  1 )
  ' В дополнительной колонке справа записать случайные числа
  Set Tmp = Rng.Columns(Rng.Columns.Count)
  With Tmp
    .Formula = "=RAND()"
    .Cells( 1 ,  1 ).Value = "Random"
  End With
  ' Отсортировать все по доп.колонке
  Rng.Sort Key1:=Tmp.Cells( 1 ,  1 ), Order1:=xlAscending, Header:=xlYes
  ' Очистить доп колонку
  If Debugging = False Then Tmp.ClearContents
End Sub

' Если важна скорость обработки
Sub RandomSort1()
  Freeze True
  ' 
  ' <-- Предыдущий код
  '
  Freeze False
End Sub

' True/False -> Заморозить/Отморозить экран, события и пересчет
Sub Freeze(OnOff As Boolean)
  With Application
    .ScreenUpdating = Not OnOff
    .EnableEvents = Not OnOff
    .Calculation = IIf(OnOff, xlCalculationManual, xlCalculationAutomatic)
  End With
End Sub

Sub RandomSort2()
  Dim TitleCell As Range, Rng As Range, Tmp As Range, i&
  Const RandomTitle = "Random"  ' <-- Заголовок доп столбца справа
  Set TitleCell = Лист1.[A3]    ' <-- Менять здесь: заголовок ФИО
  'Заморозить Excel
  Freeze True
  ' Задать диапазон данных с дополнительной колонкой справа
  Set Rng = TitleCell.CurrentRegion
  i = TitleCell.Row - Rng.Row
  If i >  0  Then Set Rng = Rng.Resize(Rng.Rows.Count - i).Offset(i)
  ' Убедиться, что заголовок последней колонки = RandomTitle
  If Rng.Cells( 1 ,  1 ).Offset(, Rng.Columns.Count -  1 ) <> RandomTitle Then
    Set Rng = Rng.Resize(, Rng.Columns.Count +  1 )
  End If
  ' Задать доп. столбец справа для случайных чисел
  Set Tmp = Rng.Columns(Rng.Columns.Count)
  ' Скрыть доп. столбец
  Tmp.EntireColumn.Hidden = True
  ' В доп. столюце справа записать случайные числа
  With Tmp
    .Formula = "=RAND()"
    '.Value = .Value ' <-- Формулы случ.чисел заменить на значения
    .Cells( 1 ,  1 ).Value = RandomTitle
  End With
  ' Отсортировать все по доп.колонке
  Rng.Sort Key1:=Tmp.Cells( 1 ,  1 ), Order1:=xlAscending, Header:=xlYes
  ' Отморозить Excel
  Freeze False
End Sub