Interested to hear your thoughts on this Secret Santa pairs picker.
It's pretty standard but I'll explain the rules all the same:
- All names go into a hat
- Each person picks a name from the hat and buys a small present for that person as a Christmas gift
- No one should pick their own name from the hat so in this circumstance they should replace the name and pick another one
This becomes problematic in real life because if someone picks their own name and puts it back they have more information about who can or cannot have their name. As such, it's a prime candidate for some computational intervention.
The Worksheet (codename Sheet1
) is simple. It contains a ListObject
named "Names" and a button linked to the following Sub.
Option Explicit
Public Sub GenerateSecretSantaPairs()
Dim namesRange As Range
With Sheet1.ListObjects("Names")
Set namesRange = Intersect(.DataBodyRange, .DataBodyRange.Columns(1))
End With
Dim hat As Scripting.Dictionary
Set hat = New Scripting.Dictionary
'fill the hat with names
Dim r As Range
For Each r In namesRange
hat.Add Key:=r.Value, Item:=r.Value
Next r
'retain original names (in order) in an array
Dim originalNames As Variant
originalNames = hat.Keys
Dim partnerNames As Variant
ReDim partnerNames(0 To hat.Count - 1)
Dim i As Long
For i = 0 To hat.Count - 1
Do
'pick a random person from the hat
Dim selectedName As String
selectedName = hat.Keys(Application.WorksheetFunction.RandBetween(0, hat.Count - 1))
Loop While originalNames(i) = selectedName And hat.Count <> 1 'try again if picked yourself unless you are the only person left in the hat
'assign partner and remove from hat
partnerNames(i) = selectedName
hat.Remove selectedName
'if last person has picked themselves then run the sub again
If partnerNames(i) = originalNames(i) Then
GenerateSecretSantaPairs
Exit Sub
End If
Next i
'ouput pairs
namesRange.Offset(0, 1).Value = Application.Transpose(partnerNames)
End Sub