Edit Randbetween macro to not include duplicates

[ffionnah]

Hi,
Could someone please help me edit this to make sure no duplicates are created?

 Sub RandPT_Ver2()Dim PT As Double, Num As Double
PT = InputBox("Enter The Total Unique Names", "Enter a Number")
Num = InputBox("Enter The 25% ", "Enter a Number")
For X = 1 To Num
    Range(ActiveCell, ActiveCell.Offset(0, 0)).Offset(X - 1) = Int((PT * rnd) + 1)
Next X
End Sub

Thank you!

 

[JoeMo]

Untested.

Sub RandPT_Ver2()
Dim PT As Variant, Num As Variant, d As Object, Try As Variant, ct As Long
Set d = CreateObject("Scripting.dictionary")
PT = InputBox("Enter The Total Unique Names", "Enter a Number")
If PT = "" Then Exit Sub
Num = InputBox("Enter The 25% ", "Enter a Number")
If Num = "" Then Exit Sub
Application.ScreenUpdating = False
For X = 1 To Num
    ct = 0
    Do
        ct = ct + 1
        Try = Int((PT * Rnd) + 1)
        If Not d.exists(Try) Then
            d.Add Try, d.Count + 1
            Range(ActiveCell, ActiveCell.Offset(0, 0)).Offset(X - 1) = Try
            Exit Do
        End If
    Loop While ct < 1000
Next X
Application.ScreenUpdating = True
End Sub

 

[Eric W]

Try:

Sub RandPT_Ver3()
Dim PT As Double, Num As Double, Wk() As Double, Out() As Double, x as Long, y as Long

    PT = InputBox("Enter The Total Unique Names", "Enter a Number")
    Num = InputBox("Enter The 25% ", "Enter a Number")
    If Num > PT Then
        MsgBox "The sample size must be less than the total size."
        Exit Sub
    End If
    ReDim Wk(1 To PT)
    ReDim Out(1 To Num, 1 To 1)
    
    For x = 1 To PT
        Wk(x) = x
    Next x
    For x = 1 To Num
        y = Int(PT * Rnd) + 1
        Out(x, 1) = Wk(y)
        Wk(y) = Wk(PT)
        PT = PT - 1
    Next x
    
    ActiveCell.Resize(Num).Value = Out
    
End Sub

This version has been tested. It avoids having to look for previously used values by removing them from the set of possible choices, so there's no extra looping.