Rank a selected range by rand in Excel

RandRanges

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Function ExistInSelection(criteria) As Boolean
    For Each a In Selection.Areas
        If WorksheetFunction.CountIf(a, criteria) Then
            ExistInSelection = True
            Exit Function
        End If
    Next
    ExistInSelection = False
End Function

Sub RandRanges()
    Dim CellsCount As Integer
    CellsCount = Selection.Cells.Count
    
    If CellsCount > 1 Then
        Dim i As Integer
        
        For i = 1 To 50
            Selection.Clear
            
            For Each c In Selection.Cells
                Dim UniqueNo As Integer
                Do
                    UniqueNo = WorksheetFunction.RandBetween(1, CellsCount)
                Loop While ExistInSelection(UniqueNo)
                    
                c.Value = UniqueNo
            Next
            
            Sleep (20)
        Next i
    End If
End Sub