# Secret Santa - Pick Pairs

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
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


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
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

• 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? – CallumDA Nov 15 '17 at 19:28
• Haha... +1 for the joke alone! – CallumDA Nov 15 '17 at 19:31
• @CallumDA You are correct!! I updated my answer. – user109261 Nov 15 '17 at 23:53
• 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! – CallumDA Nov 16 '17 at 12:26
• @CallumDA I give up!! For now..lol. Happy Coding – user109261 Nov 16 '17 at 14:43