Sub Select_Random_Names()
Dim dic As Object
Dim a As Variant, b As Variant, c As Variant, d As Variant
Dim i As Long, j As Long, k As Long, lr2 As Long, x As Long, y As Long
Dim arr As Variant, num As Long
num = 15 'random numbers
Set dic = CreateObject("Scripting.Dictionary")
a = Range("A2", Range("A" & Rows.Count).End(3)).Value
lr2 = Range("I" & Rows.Count).End(3).Row
If lr2 > 3 Then
b = Range("I3:I" & lr2).Value
If UBound(a, 1) = UBound(b, 1) Then
MsgBox "All items have been selected. It will start again."
Range("I3:I" & lr2).Cells.ClearContents
lr2 = 2
Else
For i = 1 To UBound(b, 1)
dic(b(i, 1)) = Empty
Next
End If
End If
ReDim c(1 To UBound(a, 1), 1 To 1)
ReDim d(1 To num, 1 To 1)
For i = 1 To UBound(a, 1)
If Not dic.exists(a(i, 1)) Then
j = j + 1
c(j, 1) = a(i, 1)
End If
Next
arr = Evaluate("ROW(1:" & j & ")")
Randomize
num = WorksheetFunction.Min(num, UBound(arr))
For i = 1 To num
x = Int(Rnd * j + i)
y = arr(i, 1)
arr(i, 1) = arr(x, 1)
arr(x, 1) = y
k = k + 1
d(k, 1) = c(arr(i, 1), 1)
j = j - 1
Next i
Range("I" & lr2 + 1).Resize(num).Value = d
End Sub