Sub pickRand()
Dim i As Long, j As Long, r As Long, s As Boolean, c As Long, v, d, a, colors, col As Long
Dim num
num = 3 'default number of random cells to pick
num = InputBox("How many random cells to pick?", , num)
If Not IsNumeric(num) Then Exit Sub
colors = Array(0, vbYellow, vbGreen, vbBlue, vbCyan, vbMagenta)
Set d = CreateObject("scripting.dictionary")
Randomize
Application.ScreenUpdating = False
With ActiveSheet
.Range("A20:T20").Value = .Range("A1:T1").Value
For i = 1 To 20 '20 columns = A:T, expand as you wish
ReDim a(1 To 1)
c = 1
col = 0
For j = 2 To 17
If .Cells(j, i).Interior.ColorIndex = xlNone Then
ReDim Preserve a(1 To c)
a(c) = j
c = c + 1
Else
For r = LBound(colors) To UBound(colors)
If colors(r) = .Cells(j, i).Interior.Color Then
If col < r Then col = r
End If
Next
End If
Next
If UBound(a) < num Then
MsgBox "Not enough options left!"
Exit For
End If
d.RemoveAll
s = False
c = 0
If col <= 4 Then
col = colors(col + 1)
Else
col = vbRed
End If
Do
r = CLng(((Rnd * 1000000) Mod UBound(a))) + 1
If Not d.exists(a(r)) Then
d(a(r)) = 1
s = True
c = c + 1
End If
DoEvents
Loop While s = False Or (s = True And c < num)
c = 0
r = .Cells(.Rows.Count, i).End(xlUp).Row + 1
For Each v In d.keys
.Cells(r + c, i).Value = .Cells(CInt(v), i).Value
.Cells(r + c, i).Interior.Color = col
.Cells(CInt(v), i).Interior.Color = col
c = c + 1
Next
Next
End With
Application.ScreenUpdating = True
End Sub
