Secret Santa Worksheet

I made a worksheet for everyone who wants to do a Secret Santa gift exchange but doesn't own a hat.  You type in a list of names (the gift givers), click a button, and get a new list of names (the gift receivers) randomly shuffled with no name in its previous position.  I almost decided to sell this, but several things changed my mind:

1. My VBA coding skills are actually horrible and I'd be ashamed to profit from them.
2. It would almost certainly complicate my taxes which I can barely do as it is.
3. I couldn't find any terms of use for the Santa image but I was too lazy to find a replacement.
4. The only people who would buy it would be people who read my blog, and I love you all too much to let money come between us.

So, uh, happy holidays.  I hope it fits.  What?  You want to know how it works?  Sigh...

Okay so my stupid worksheet looks like this:

Oh look, it's being ironically festive!  Maybe it should move to Capitol Hill and read the Stranger on its iPhone while wearing jeans that are way too small!  If you don't live in Seattle you have no idea what I'm talking about!

Anyway, let me point out the nicer features:

Images
I grabbed that Santa from a Secret Santa excel template that Microsoft hosts.  Their template sucks though because it doesn't shuffle the names for you, so don't bother looking for it.  I googled "free holiday clip art" to get those other two images.

Dynamic Named Ranges
Dynamic named ranges are awesome.  I think I first read about them on the PHD Blog.  Anyway, there are three in this worksheet, but they all look like this, which points to the gift givers column:

=OFFSET('Secret Santa Name Picker'!$C$3,0,0,COUNTA('Secret Santa Name Picker'!E:E)-1,1)

So it's just counting how many entries there are in all of column C, subtracting out 1 for the column title, and creating a range with that height starting at cell C3.  I guess I should briefly explain the offset function.  It returns a cell or range reference, and the arguments are as follows:

=OFFSET(starting cell, cells moved left (negative for right), cells moved down (negative for up), range height, range width)

So my formula starts at cell C3, doesn't offset because that is the column I want, and has a height equal to the entries in the column (less the title) and a width of one.  Now the name, Givers, will always point to all of the names in column C, no matter how many I enter.  Don't try to be clever and break it by leaving blank spaces in the middle of the list, and yes that will break it.  The other ranges are Receivers (self explanatory) and Dummy (which refers to me for having to add a "helper" column because I don't know how to use data types in VBA).

Button

A button!  I really have no idea how this works.  I cannibalized two pieces of code, mashed them together, and ran through the debugger about a million times tweaking things until it finally worked.  The basic idea: I take the input range, Givers, and copy its entries to the Receivers range.  At the same time I populate the Dummy range with random numbers.  I then sort both Receivers and Dummy by the values in Dummy, effectively randomizing the order of the names.  Finally, I run back through both Givers and Receivers making sure none of the entries match (if your family allows people to draw their own name in Secret Santa, you're doing it wrong).  If the entries do match, it goes back through the array and switches it with the first value that won't cause either entry to match the Givers range.

Here it is:

Private Sub CommandButton1_Click()
    Dim xTemp As Double
    Dim yTemp As String
    Dim i As Long
    Dim j As Long
    Dim vArr As Range
    Dim l As Integer
    Dim moreDifferentArray As Range
    Dim returnArray As Range
    
    l = Range("arraysize")
    Set vArr = Range("Givers")
    Set returnArray = Range("Receivers")
    Set moreDifferentArray = Range("Dummy")
     'pass range values to  array
    
    'add randomness
    For i = 1 To l
        returnArray(i) = vArr(i)
        moreDifferentArray(i) = Rnd()
    Next i
   
    'sort I think. Forgot where this came from, sorry...
    For j = 2 To l
        xTemp = moreDifferentArray(j)
        yTemp = returnArray(j)
            For i = j - 1 To 1 Step -1
                If (moreDifferentArray(i) <= xTemp) Then GoTo 10
                moreDifferentArray(i + 1) = moreDifferentArray(i)
                returnArray(i + 1) = returnArray(i)
            Next i
        i = 0
10      moreDifferentArray(i + 1) = xTemp
        returnArray(i + 1) = yTemp
    Next j

    
     'check for dupes
     For i = 1 To l
        If vArr(i) = returnArray(i) Then
            For j = 1 To l
                If vArr(j) <> returnArray(i) Then
                    yTemp = returnArray(i)
                    returnArray(i) = returnArray(j)
                    returnArray(j) = yTemp
                    j = l
                End If
            Next j
        End If
    Next i
       
End Sub

That's about all there is to it.  You can download the workbook here.  Remember to enable macros or it won't work.  Happy holidays!

-David