VBA code to randomly pick from a list of names

[danbates77]

Hi,

I have this code that randomly picks a different name from a list.

Sub CommandButton1_Click()

Dim lrcd As Long


SendKeys "%^{F9}"


Range("H31").Copy
'Range("C2:C7").PasteSpecial xlPasteValues


lrcd = Sheets("Sheet1").Range("E" & Rows.Count).End(xlUp).Row


Sheets("Sheet1").Cells(lrcd + 1, "E").PasteSpecial xlPasteValues


End Sub

The F9 part in the code is to trigger this formula which is in H31

=INDEX(A1:A12,RANDBETWEEN(1,COUNTA(A1:A12)),1)

What I would like is when it randomly picks a name and enters it in column E, it cannot enter that name again.

I hope this makes sense.

Thanks

Dan

 

[Worf]

Be sure to go to another sheet and then back to the sheet in question, in order to trigger the activate event:

Dim col As Collection, rb, i%
' sheet module
Sub CommandButton1_Click()
If col.count > 0 Then                                                   ' collection not empty
    rb = WorksheetFunction.RandBetween(1, col.count)
    Me.Cells(Me.Range("E" & Rows.count).End(xlUp).Row + 1, 5) = col(rb) ' write to sheet
    col.Remove CStr(col(rb))                                            ' already used
End If
End Sub


Private Sub Worksheet_Activate()
Set col = New Collection
For i = 1 To Range("a" & Rows.count).End(xlUp).Row
    col.Add CStr(Me.Cells(i, 1)), CStr(Me.Cells(i, 1))      ' possible options
Next
If WorksheetFunction.CountA(Me.[e:e]) > 0 Then
    For i = 1 To Me.Range("e" & Rows.count).End(xlUp).Row
        col.Remove CStr(Me.Cells(i, 5))                     ' already used
    Next
End If
End Sub

 

[danbates77]

Hi,

Thank you for your reply. Unfortunately it is coming up with the following error:

Run time error 91 - Object variable or with blocked variable not set

If col.Count > 0 Then                                                   ' collection not empty

This is how I have it in my sheet module:

Option Explicit

Dim col As Collection, rb, i%
' sheet module
Sub CommandButton1_Click()
If col.Count > 0 Then                                                   ' collection not empty
    rb = WorksheetFunction.RandBetween(1, col.Count)
    Me.Cells(Me.Range("E" & Rows.Count).End(xlUp).Row + 1, 5) = col(rb) ' write to sheet
    col.Remove CStr(col(rb))                                            ' already used
End If
End Sub




Private Sub Worksheet_Activate()
Set col = New Collection
For i = 1 To Range("a" & Rows.Count).End(xlUp).Row
    col.Add CStr(Me.Cells(i, 1)), CStr(Me.Cells(i, 1))      ' possible options
Next
If WorksheetFunction.CountA(Me.[e:e]) > 0 Then
    For i = 1 To Me.Range("e" & Rows.Count).End(xlUp).Row
        col.Remove CStr(Me.Cells(i, 5))                     ' already used
    Next
End If
End Sub

Thanks again

Dan

 

[Worf]

I did not receive an email warning me about your post. If I do not answer again, send me a PM.
New version is below,note that there is a new reset button.

Dim col As Collection, rb, i%
' sheet module
Sub CommandButton1_Click()
If col Is Nothing Then DoThing
If col.Count > 0 Then                                                   ' collection not empty
    rb = WorksheetFunction.RandBetween(1, col.Count)
    Me.Cells(Me.Range("E" & Rows.Count).End(xlUp).Row + 1, 5) = col(rb) ' write to sheet
    col.Remove CStr(col(rb))                                            ' already used
End If
End Sub

Sub DoThing()
Set col = New Collection
For i = 1 To Range("a" & Rows.Count).End(xlUp).Row
    col.Add CStr(Me.Cells(i, 1)), CStr(Me.Cells(i, 1))      ' possible options
Next
If WorksheetFunction.CountA(Me.[e:e]) > 0 Then
    For i = 1 To Me.Range("e" & Rows.Count).End(xlUp).Row
        col.Remove CStr(Me.Cells(i, 5))                     ' already used
    Next
End If
End Sub

Private Sub CommandButton2_Click()                          ' reset button
Me.[e:e].ClearContents
DoThing
End Sub

Private Sub Worksheet_Activate()
DoThing
End Sub

 

[danbates77]

Hi Worf,

I have forgot to mention I have a header in cell E6. This code works perfectly when I delete the header but I would prefer to keep the header if that's ok?

Thanks again for all your help.

Kind Regards

Dan

 

[Worf]

Hi Dan

I am going off-line now but will work on it as soon as possible…

 

[Worf]

New version:

Dim col As Collection, rb, i%, lr%
' sheet module
Sub CommandButton1_Click()
If col Is Nothing Then DoThing
If col.Count > 0 Then                                                   ' collection not empty
    rb = WorksheetFunction.RandBetween(1, col.Count)
    Me.Cells(Me.Range("E" & Rows.Count).End(xlUp).Row + 1, 5) = col(rb) ' write to sheet
    col.Remove CStr(col(rb))                                            ' already used
End If
End Sub

Sub DoThing()
Set col = New Collection
For i = 1 To Range("a" & Rows.Count).End(xlUp).Row
    col.Add CStr(Me.Cells(i, 1)), CStr(Me.Cells(i, 1))      ' possible options
Next
lr = Me.Range("e" & Rows.Count).End(xlUp).Row
If WorksheetFunction.CountA(Me.Range("e7:e" & lr)) > 0 Then
    For i = 7 To lr
        col.Remove CStr(Me.Cells(i, 5))                     ' already used
    Next
End If
End Sub
Private Sub CommandButton2_Click()                          ' reset button
Me.[e7:e1000].ClearContents
DoThing
End Sub
Private Sub Worksheet_Activate()
DoThing
End Sub

 

[Peter_SSs]

Here is another option to test.

Private Sub CommandButton1_Click()
  Dim d As Object
  Dim i As Long
  Dim Resp As VbMsgBoxResult
  
  Set d = CreateObject("Scripting.Dictionary")
  For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
    d(Range("A" & i).Value) = Empty
  Next i
  For i = 7 To Range("E" & Rows.Count).End(xlUp).Row
    d.Remove Range("E" & i).Value
  Next i
  If d.Count > 0 Then
    Randomize
    Range("E" & Rows.Count).End(xlUp).Offset(1).Value = d.Keys()(Int(Rnd() * d.Count))
  Else
    Resp = MsgBox("List exhausted. Clear items from column E?", vbYesNo)
    If Resp = vbYes Then Range("E7", Range("E" & Rows.Count).End(xlUp)).ClearContents
  End If
End Sub

 

[Worf]

It seems that randomize should be called only once per session:

http://www.excelfox.com/forum/showt...Function-Should-Be-Run-Only-Once-Per-Session?

 

[Peter_SSs]

It seems that randomize should be called only once per session:

http://www.excelfox.com/forum/showt...Function-Should-Be-Run-Only-Once-Per-Session?

I'm not expert enough on what is happening behind the scenes with that but I have just run quite a few tests creating up to 20,000 sets of results with my code and with the structure suggested in that link and to be honest I cannot see any discernible difference in the "randomness" of the results. However, I see no disadvantage in checking if Randomize has already been applied so no problem if the OP wants to incorporate that.