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