Try running this:
Sub RandomPull2()
Dim r As Range
Dim rs As Long, r2 As Double, c As Long, max As Long
Set r = Worksheets("Key List").Range("Table5[Key]")
max = r.rows.Count
rs = CLng(max / 100 * 25) 'percentage - adjust accordingly
c = 0
Randomize
With CreateObject("scripting.dictionary")
Do While c < rs
r2 = Rnd
r2 = (r2 * 1000000) - ((max - 1) * Int((r2 * 1000000) / (max - 1))) + 1
Do While .Exists(r(r2).Value)
r2 = Rnd
r2 = (r2 * 1000000) - ((max - 1) * Int((r2 * 1000000) / (max - 1))) + 1
Loop
.Add r(r2).Value, 1
c = c + 1
Loop
Worksheets("Random List").Range("A1").Resize(.Count) = Application.Transpose(.keys)
End With
Set r = Nothing
End Sub
Bookmarks