Exclude Range from Random Name Generator

  • Thread starter Thread starter sswilcox
  • Start date Start date
S

sswilcox

This is not work-related. I've been using Excel to draw random names
for my family's annual Christmas gift exchange for several years.
There are four families and a family cannot end up with anyone from
their own family. The best I've been able to do is 'draw' one name at
a time and assign each to a family - throwing the name back if it
happens to come from the family I'm drawing for at the moment.
I'd like to take this to the next level by figuring out a way to limit
the selection pool based on the family by excluding its own members.
So the names in Family A's hat will only include members of Families
B, C and D, and so on. The families are not equal in size.
I'm pretty sure I could cobble together some series of IF(), RAND(),
RANK(), and VLOOKUP()s in order to get where I want to be, but I bet
there is some slick VBA solution out there somewhere. Can anyone point
me in the right direction?

Thanks - sswilcox
 
S,

You really need an iterative process, since the last member drawn could get
his/her own name. So VBA is the way to go.

Try the macro below. Set up a two column, multi-row range named
"GiftGivers" Do not include the header row when naming the range.

Start with the largest family first, and go down to the smallest family
last. In the first column of GiftGivers, use a unique family name - if
every body has the same last name (Wilcox), you could use, for example -
"Southern Wilcox Family" "Bob's family", 1, etc..

In the second column, enter the name of the person, with or without their
last name.

Then run the macro below. If you have a very lopsided gathering (say, 10
from one family, 10 from 4 other families) it may take a while to converge
(it took 7000 trials for that case when the 10 were listed last, and just
one try when they were listed first - right now, it cuts off after 100
tries - and if you have more than half of the gathering from one family, it
can never find a solution). For evenly spread attendees from 5 families, it
typically converged in 3 or fewer attempts. It isn't written to be optimized
for CPU usage, just to randomize the draw and to prevent family members from
drawing family members. If the last family listed has the most members, it
can take many more tries than if they are listed first, due to the order of
processing attendees.


HTH,
Bernie
MS Excel MVP


Sub AssignGifts()
Dim Assignments() As Variant
Dim i As Integer
Dim j As Integer
Dim myRand As Integer
Dim Tries As Integer
Dim LCount As Integer
Dim RStart As Integer
Dim CStart As Integer

LCount = 0

Restart:
LCount = LCount + 1
j = Range("GiftGivers").Rows.Count

ReDim Assignments(1 To 4, 1 To j)

For i = 1 To j
Assignments(1, i) = Range("GiftGivers").Cells(i, 1).Value
Assignments(2, i) = Range("GiftGivers").Cells(i, 2).Value
Assignments(3, i) = "Not Assigned"
Assignments(4, i) = 0
Next i

For i = 1 To j
Tries = 0
FindMatch:
myRand = Application.Min(j, Int(j * Rnd()) + 1)
If Assignments(3, myRand) = "Not Assigned" And _
Assignments(1, myRand) <> Assignments(1, i) Then
Assignments(3, myRand) = "Assigned"
Assignments(4, i) = myRand
Else
Tries = Tries + 1
If Tries >= 30 Then
GoTo Restart:
Else
GoTo FindMatch
End If
End If

Next i

RStart = Range("GiftGivers").Cells(1, 1).Row
CStart = Range("GiftGivers").Cells(1, 1).Column + 2
For i = 1 To j
Cells(RStart + i - 1, CStart).Value = Assignments(1, Assignments(4,
i))
Cells(RStart + i - 1, CStart + 1).Value = Assignments(2,
Assignments(4, i))
Next i

MsgBox "I had to try " & LCount & " times."

End Sub
 
This is brilliant, Bernie. Thank you very much. It is cycling through
usually just one time, sometimes two or three, before it finds a
suitable solution. I have mapped this to a button on the worksheet and
set up a little table that filters the VBA results by family. Due to
the population size (16 names) it sometimes doesn't achieve as varied
results as I might like (e.g. one family might draw members from just
one other family - but the same thing could just as easily happen with
paper slips in a hat) so I just executed the code until I was
satisfied. Your routine is so good. Thanks again for lending me some
of your time and knowledge for my totally unimportant project.

-sswilcox
 
Back
Top