Secret Santa - Pick Pairs

Question

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

Answer 1

Very cool ideal.

Variable Declaration

Variables should be declared at the top of the subroutine. Variables should also be instantiated following the variable declarations when it makes sense to do so. Separating variable declaration and instantiation from the body of the subroutine improves readability and allows you to better focus on the "Business Logic".

Names, Name, Name2

Naming is an essential skill that you need to develop to write good code.

Compare the following

• Sheet1.ListObjects("Names") or Sheet1.ListObjects("Names") : Sheet1.ListObjects("SecretSantaTable")
• Name column: Santas column
• Name2 column: Children column

Random Stuff

The two lines of ↓code below↓ both target the same range

Set namesRange = Intersect(.DataBodyRange, .DataBodyRange.Columns(1)) Set namesRange = .ListColumns("Names").DataBodyRange

Why use a WorksheetFunction when you can use a VBA function?

selectedName = hat.Keys(Application.WorksheetFunction.RandBetween(0, hat.Count - 1)) selectedName = hat.Keys(Int(Rnd * hat.Count))

I would use an ArrayList instead of a Dictionary because you don't need Key/Value pairs.

Here is how I would do it. But it's still not quite right...I'll be back!

Public Sub Refactored_GenerateSecretSantaPairs()
    Dim key As Variant
    Dim n As Long, x As Long
    Dim tbl As ListObject, source As Range
    Dim Santas As Object, Children As Object
    Set tbl = Sheet1.ListObjects("SecretSantaTable")
    Set Santas = CreateObject("System.Collections.ArrayList")
    Set source = tbl.ListColumns("Santas").DataBodyRange

    If source Is Nothing Then Exit Sub
    'Remove Duplicates and Reset Source Range
    source.RemoveDuplicates (1)
    Set source = tbl.ListColumns("Santas").DataBodyRange

    For Each key In source.Value
        Santas.Add key
    Next

    Set Children = Santas.Clone

    For x = 0 To Santas.Count - 1
        Do
            n = Int(Rnd * Children.Count)
            key = Children(n)
        Loop Until key <> Santas(x) Or Children.Count = 1

        If Children.Count = 1 And Santas(x) = key Then
            key = Santas(x - 1)
            Santas(x) = Santas(x - 1)
        End If

        Santas(x) = key
        Children.Remove key
    Next

    tbl.ListColumns("Children").DataBodyRange.Value = Application.Transpose(Santas.ToArray)

End Sub

I recommend that you further simplify the Macro, reducing it to 3 lines of code:

Public Sub GenerateSecretSantaPairs()
    Sheet1.ListObjects("Names").ListColumns("Name2").DataBodyRange.Value = "Thomas Inzina"
End Sub