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.

enter image description here

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
            '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
            Exit Sub
        End If
    Next i

    'ouput pairs
    namesRange.Offset(0, 1).Value = Application.Transpose(partnerNames)
End Sub

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

    Set Children = Santas.Clone

    For x = 0 To Santas.Count - 1
            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

    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
  • \$\begingroup\$ Thank you for this - I didn't know ArrayList existed! Re: the code which you said isn't needed. What happens if the last person can only pick themselves? Surely you end up in an infinite loop? \$\endgroup\$ – CallumDA Nov 15 '17 at 19:28
  • \$\begingroup\$ Haha... +1 for the joke alone! \$\endgroup\$ – CallumDA Nov 15 '17 at 19:31
  • 1
    \$\begingroup\$ @CallumDA You are correct!! I updated my answer. \$\endgroup\$ – user109261 Nov 15 '17 at 23:53
  • \$\begingroup\$ Hey Thomas, the code still goes into an infinite loop (there's no logic to escape the loop) and your update just means that the last two people get the same "Children". Does it even matter though? I've gained more than enough from your answer -- it doesn't have to be perfect! \$\endgroup\$ – CallumDA Nov 16 '17 at 12:26
  • 1
    \$\begingroup\$ @CallumDA I give up!! For now..lol. Happy Coding \$\endgroup\$ – user109261 Nov 16 '17 at 14:43

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.