'Module by Vixay for DonationCoder
Option Explicit
'API for windows sleep
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub StartRandomizer()
'Moves a shape along the cells, and changes color of the final cell
' No exclusivity for now
'30 ms = fast
'100 ms = slow
'150 ms = stop
Dim shpActive As Shape
Dim rCell As Range
Dim lSpeed As Long
Dim lSpeedMax As Long
Dim lWinner As Long
Dim lCount As Long

lSpeed = 30
lSpeedMax = 150
Randomize
lWinner = SelectWinner()
Debug.Print "to be winner:" & lWinner
'get the shape we will use ( must exist or will cause an error )
If ActiveSheet.Shapes.Count > 1 Then
    Set shpActive = ActiveSheet.Shapes(1)
Else
    Set shpActive = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, 10, 10, 10, 10)
    shpActive.Fill.Transparency = 0.8
End If

For lSpeed = 30 To lSpeedMax Step 20
    lCount = 0
    For Each rCell In ListArea.Cells
        lCount = lCount + 1
        AlignShapeTo shpActive, rCell
        'Debug.Print rCell.Address
        DoEvents
        'Application.ScreenUpdating = True
        Sleep lSpeed
        'slow down speed randomly with a low probability
        ' i.e. continue through all cells most of the time at the current speed
        ' except no random slowdowns on the last stage
        If Rnd >= 0.95 And lSpeed < 130 Then
        'can tweak the number here to change how often we randomly switch speeds
            lSpeed = lSpeed + 20
            Debug.Print "random speed slowdown:" & lSpeed
        End If
        'if at winner cell, and at final slowdown stage
        If lSpeed >= lSpeedMax And lCount = lWinner Then
            Debug.Print "Found our winner"
            rCell.Interior.Color = vbRed
            Exit For 'stop here
        End If
        'Debug.Print lSpeed
    Next rCell
    Debug.Print "next slowdown:" & lSpeed
Next lSpeed

End Sub

Sub AlignShapeTo(ByRef shpObj As Shape, rCell As Range)
shpObj.Top = rCell.Top
shpObj.Left = rCell.Left
shpObj.Height = rCell.Height
shpObj.Width = rCell.Width
End Sub

Function ListArea() As Range
'Change this function to suit your needs or just make sure your
' active cell is within your table range
Set ListArea = ActiveCell.CurrentRegion
'Set ListArea = Selection
End Function

Function SelectWinner() As Long
'Randomly choose a cell amongst all the cells
Dim lCellCount As Long
lCellCount = ListArea.Count
Randomize
SelectWinner = Rnd * lCellCount + 1
Debug.Print SelectWinner & " / " & lCellCount
End Function

Sub ClearBackgrounds()
ActiveCell.CurrentRegion.Interior.ColorIndex = xlColorIndexNone
End Sub