Random name selector in Powerpoint (or maybe Excel?)

[ma0ffst08]

Hello all,

I would like to make something in Powerpoint where I can enter a list of names (this list doesn't always have the same number of names), and each name would be represented in a pie chart with an equal percentage for each name. If a name is repeated once, this would be represented with 2 slices of the pie. If the name is on there 3 times, it would have 3 slices of the pie etc.

This is for a school project - basically children get given points towards an end of term prize draw - the more points they have, the more 'tickets' they have into this draw, where we will be drawing 20-30 winners.

When I press a button, the wheel spins, and a random winner is drawn and the name displayed. Whichever name is drawn, this slice of he pie then gets removed, and the process can be continued

So for example:
John has 4 'tickets'
Tim has 3
Anna has 2
Tracey has 1.

At the start, John would be represented with 40% of the pie, Tim with 30%, Anna 20% and Tracey 10%.
After 1 round, John is drawn out.

So in the next iteration, John has 3 tickets remaining, Tim 3, Anna 2, Tracey 1.
If Tracey is drawn out in the second round, she cannot then be drawn out in round 3, etc

I want to be able to edit the list of names at any point before this thing runs, and if it works visually, this would be amazing, hence Powerpoint. If it can be done visually in excel, then so be it.

I am completely lost as to where to start with this, so any help hugely appreciated.

Thanks so much

 

[ranman256]

EXCEL
paste code into module
column A holds all ticket holder names. (starting in A2)

put a button on sheet to run macro: Pick1Winner
the code will load the names then randomly pick and post the winner in Col.F

Public gcolNames As Collection
Public iPicks As Integer

Public Sub Pick1Winner()
LoadNames
Pick1Rando
End Sub

Private Sub LoadNames()
Dim sName As String
    
On Error Resume Next

If gcolNames Is Nothing Or gcolNames.Count = 0 Then
   If MsgBox("Begin New Game", vbQuestion + vbYesNo, "Confirm") = vbNo Then End
   
   ClearResults
   
   Set gcolNames = New Collection
   iPicks = 0
   
    Range("A2").Select
    While ActiveCell.Value <> ""
       sName = ActiveCell.Value
       gcolNames.Add sName
       
       ActiveCell.Offset(1, 0).Select 'next row
    Wend
    
      'start of winners list
    Range("F12").Select
Else
   'list already loaded
End If
End Sub


Private Sub Pick1Rando()
Dim iRows As Long, r As Long
Dim iRnd As Integer
Dim vName

On Error Resume Next

    'pick random
iRnd = Int((gcolNames.Count * Rnd) + 1)

  'post winner
iPicks = iPicks + 1
vName = gcolNames(iRnd)
ActiveCell.Offset(0, 0) = iPicks
ActiveCell.Offset(0, 1) = vName

ActiveCell.Offset(1, 0).Select   'next row

'remove winner from list
gcolNames.Remove iRnd
If gcolNames.Count = 0 Then MsgBox "Game Over"
End Sub

Private Sub ClearResults()
Columns("F:G").ClearContents
End Sub

 

[ma0ffst08]

That is amazing thank you! Is there a way that when a winner is picked, that cell in column A is highlighted please? So as you run through, more and more names get highlighted?

 

[ranman256]

hm , i musta sent the older code. This highlights the winners:

Public Const Q = """"
Public Const giColWin = 8   'col.H
Public gcolNames As Collection
Public giPickCt As Integer
Public rng As Range

Public Sub PickWinners()
Dim vRet
Dim i As Integer

'start over
 vRet = InputBox("How many winners?", "Winners to choose")
If vRet = "" Or vRet <= 0 Then Exit Sub
 
giPickCt = vRet

LoadNames
For i = 1 To giPickCt
   Pick1Rando
   If gcolNames.Count = 0 Then GoTo endit
Next

endit:
MsgBox "Game Over"
End Sub


Private Sub LoadNames()
Dim sName As String
    
On Error Resume Next

If gcolNames Is Nothing Or gcolNames.Count = 0 Then
   'If MsgBox("Begin New Game", vbQuestion + vbYesNo, "Confirm") = vbNo Then End
   
   ClearResults
   
   Set gcolNames = New Collection
   ''iPicks = 0
   
    Range("A2").Select
    While ActiveCell.Value <> ""
       sName = ActiveCell.Value
       gcolNames.Add sName, sName
       
       ActiveCell.Offset(1, 0).Select 'next row
    Wend
    
      'start of winners list
    Cells(2, 8).Select
Else
   'list already loaded
End If
End Sub


Private Sub Pick1Rando()
Dim iRows As Long, r As Long
Dim iRnd As Integer
Dim vName

On Error Resume Next

    'pick random
iRnd = Int((gcolNames.Count * Rnd) + 1)

  'post winner
'iPicks = iPicks + 1
vName = gcolNames(iRnd)


ActiveCell.Offset(0, 0).Value = vName

 'bookmark our spot
Set rng = ActiveCell
Redline vName
rng.Select

ActiveCell.Offset(1, 0).Select   'next row

'remove winner from list
gcolNames.Remove iRnd
End Sub

Private Sub ClearResults()
Dim vLtr
vLtr = cvtColNum2Ltr(giColWin)
Columns(vLtr & ":" & vLtr).ClearContents
Range(vLtr & "1").Value = "Winners"
ClearRedline
End Sub

Private Sub Redline(ByVal pvName)

    Columns("A:A").Select
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=" & Q & pvName & Q
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Font
        .Color = -16383844
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 13551615
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
End Sub

Private Sub ClearRedline()
    Cells.FormatConditions.Delete
    Range("A1").Select
End Sub

Private Function cvtColNum2Ltr(ByVal pvColNum)
Dim vRet
vRet = Mid(Cells(1, pvColNum).Address, 2)
cvtColNum2Ltr = Left(vRet, InStr(vRet, "$") - 1)
End Function