Randomly select names form list, no duplicates, cannot select from same family

[jteti09]

Hi All,

I wanted to put together a quick spreadsheet for my family to quickly assign pollyanna names (Christmas gift-giving event, for those unfamiliar). Obviously, everyone in the pool should receive a gift and we do not want people in the same nuclear family (i.e. siblings) to be assigned to one another, and each name should also not be assigned to itself. I have the first names in column A, and last names in Column B, and I would like to place the first name of the person for which the gift should be bought in column E.

So far, I was able to throw together this simple code (after some googling)to randomly generate a match that is not in one's nuclear family, and is not one's self:

Sub randm()


Dim sh As Worksheet, nr As Long


Static AlreadyRandomized As Boolean
If Not AlreadyRandomized Then
AlreadyRandomized = True
Randomize
End If


Set sh = Sheets(1) 'Edit sheet name

For i = 2 To 29
Do
nr = Int((29 - 2 + 1) * Rnd + 2)
Loop While sh.Range("B" & i).Value = sh.Range("B" & nr).Value
sh.Range("E" & i) = sh.Range("A" & nr)
Next i

End Sub


However, for the life of me, I can't figure out how to make the code check the randomly generated name (A & nr) against the range of previously generated names, and re-generate a new name if found to be a duplicate.

Anyone have a suggestion?

 

[NdNoviceHlp]

Seems like a fun and useful holiday tool. Enjoy. Dave

Option Explicit
Private Sub Polyana()
Dim Lastrow As Integer, Cnt As Integer
Dim FirstRow As Integer, SecondRow As Integer
'Creates random pairs of gift exchangers
'Doesn't allow same last names to exchange gifts
'First Name in "A"; Last name in "B" ("Sheet1")
'Match output First Name in "E"; Last Name in "F"

Randomize
With Sheets("Sheet1")
    Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
'clear previous results
Sheets("Sheet1").Range(Sheets("Sheet1").Cells(1, "C"), _
Sheets("Sheet1").Cells(Lastrow, "F")).ClearContents

If Lastrow Mod 2 <> 0 Then
MsgBox "Some one's buying there own present!"
End If

Cnt = 0
Do
abovefirstrow:
If Cnt > 1000 Then
MsgBox "No more matches"
Exit Sub
End If
FirstRow = Int((Lastrow * Rnd) + 1)
If Sheets("Sheet1").Range("C" & FirstRow).Value <> vbNullString Then
Cnt = Cnt + 1
GoTo abovefirstrow
End If
abovesecondrow:
SecondRow = Int((Lastrow * Rnd) + 1)
If Sheets("Sheet1").Range("C" & SecondRow).Value <> vbNullString Then
GoTo abovesecondrow
End If
If FirstRow = SecondRow Then
Cnt = Cnt + 1
GoTo abovefirstrow
End If
If Sheets("Sheet1").Range("B" & FirstRow).Value = _
           Sheets("Sheet1").Range("B" & SecondRow).Value Then
Cnt = Cnt + 1
GoTo abovefirstrow
End If
Sheets("Sheet1").Range("e" & FirstRow).Value = Sheets("Sheet1").Range("A" & SecondRow).Value
Sheets("Sheet1").Range("f" & FirstRow).Value = Sheets("Sheet1").Range("B" & SecondRow).Value
Sheets("Sheet1").Range("e" & SecondRow).Value = Sheets("Sheet1").Range("A" & FirstRow).Value
Sheets("Sheet1").Range("f" & SecondRow).Value = Sheets("Sheet1").Range("B" & FirstRow).Value
Sheets("Sheet1").Range("C" & FirstRow).Value = "Done"
Sheets("Sheet1").Range("C" & SecondRow).Value = "Done"
Cnt = 0
Loop
End Sub

 

[NdNoviceHlp]

Missed the Edit. Should have mentioned that U may have to run the code a few times before all matches are made ie. the random nature of the matches may preclude all people being matched based on the rules for being matched.... if everyone doesn't get matched then run the code again. Just remember that based on the rules there may be no further matches ie. If everyone has the same last name U can run the code until your fingers are tired... U still won't get a match. Dave

 

[Peter_SSs]

I have assumed ..
- Data is on the active sheet when the code is run
- Names start in row 2 of columns A & B, and no blank cells in the list of names in those columns.
- Nuclear family is defined by column B names

Depending on how many names are in your list, you may want/need to experiment with increasing the 'MaxTries' value if you find that you are running the code and getting a message box saying that a result was not found within that many tries.

I would suggest that you test in a copy of your workbook.

Sub Names_List()
  Dim Full As Variant, Short As Variant, Result As Variant, Remaining As Variant
  Dim Tries As Long, i As Long, lr As Long, ubF As Long
  Dim CurrLast As String
  
  Const MaxTries As Long = 1000
  
  Randomize
  lr = Range("A" & Rows.Count).End(xlUp).Row
  Full = Application.Transpose(Evaluate("A2:A" & lr & "&"" |""&B2:B" & lr & "&""|"""))
  Remaining = Full
  ubF = UBound(Full)
  i = 1
  Do
    If i = 1 Then ReDim Result(1 To ubF, 1 To 1)
    Tries = Tries + 1
    CurrLast = Mid(Full(i), InStr(1, Full(i), "|"))
    Short = Filter(Remaining, CurrLast, False)
    If UBound(Short) = -1 Then
      Remaining = Full
      i = 1
    Else
      Result(i, 1) = Short((Rnd() * UBound(Short)))
      Remaining = Filter(Remaining, Result(i, 1), False)
      Result(i, 1) = Replace(Result(i, 1), "|", "")
      i = i + 1
    End If
  Loop Until Tries = MaxTries Or Result(ubF, 1) <> ""
  If Result(ubF, 1) <> "" Then
    Range("E2:E" & lr).Value = Result
  Else
    MsgBox "Unable to produce a result after " & MaxTries & " attempts"
  End If
End Sub

My sample data and result:

Book1
	A	B	C	D	E
1	First	Last			Gift Recipient
2	Tom	Jones			Anne Smith
3	Anne	Jones			Tim Smith
4	Ken	Jones			Tom Smith
5	Tom	Hall			Anne Jones
6	Jen	Hall			Ken Smith
7	Bob	Bloggs			Jen Hall
8	Anne	Smith			Ken Jones
9	Ken	Smith			Tom Jones
10	Tim	Smith			Tom Hall
11	Tom	Smith			Bob Bloggs
Names List

 

[NdNoviceHlp]

Wow Peter... that's some interesting code. It seems to work as per the original request. My notion of the gift exchange was that 2 random people on the list would exchange gifts between themselves... which upon review of the original request was not required. Everyone on the list gets a gift from someone else was the request which your code somehow manages to output. My brain cramps trying to figure how U done it but it seems like U done it. I'm sure that the thread starter and family will enjoy their X-mas. Dave