VBA code to generate random pairs without duplicates (kind of)

[bsweet0us]

Sub RandomPairing()
Dim Cnt As Long, RandomIndex As Long, Tmp As Variant, Arr As Variant, lastrow As Long

  Sheets("helper blind").Activate
  
  With ActiveSheet
  lastrow = .Range("A6:A250").Find("*", searchdirection:=xlPrevious, searchorder:=xlByColumns, LookIn:=xlValues).Row
  End With
  
Randomize:

  Randomize
  
  Arr = Range("A6", "A" & lastrow)
  
  For Cnt = UBound(Arr) To 1 Step -1
    RandomIndex = Int((Cnt - LBound(Arr) + 1) * Rnd + LBound(Arr))
    Tmp = Arr(RandomIndex, 1)
    Arr(RandomIndex, 1) = Arr(Cnt, 1)
    Arr(Cnt, 1) = Tmp
  Next
  Range("M6").Resize(UBound(Arr)) = Arr
  Range("M6").Offset(UBound(Arr) / 2).Resize(UBound(Arr)).Cut Range("N6")
  
Call PlaceTeams
End Sub

At the suggestions of @StephenCrump I've created this thread to try and come up with some code to generate random pairs with not duplicating any pre-existing pairs. The original thread can be found here if you want to see how it started.

Leading into the code above, the user will enter a list of participants that will be placed in column A beginning with row 6. The issue is some of the names in the list will already be paired with another name in the list and I need to ensure the randomized pairs don't match up with the pairs already entered. The existing pairs are in another sheet in column C beginning in row 5. Each pair in this column is in adjacent rows (C5 is paired with C6, C7 is paired with C8, etc.)

I'm open to new code that will randomize the list after taking into account the existing pairs OR a snippet of code that will compare the randomized pairs to the existing pairs and re-randomize as many times as needed so no pairs match.

THANKS!

 

[bsweet0us]

Why do you remove this line?

 If coll.Count = 2 Then va(uva, 1) = coll(1): va(uva, 2) = coll(2): Exit Do

in my test, when there are only 2 names left, it tends to go to endless loop, it happens once in about 10-15 round, that's why I added the line.

I didn't replace the code you most recently posted because it worked in my limited test matter. I didn't realize you made that adjustment and will add it in now.

Thanks for proofing the code!

ETA: Double-checked my code with yours and made the adjustments.

 

[Akuini]

You're welcome, glad to help & thanks for the feedback.
And on a bigger data size you might want to increase the limit of the loop in this part:

qq = qq + 1: If qq > 20000 Then MsgBox "Endless loop": Exit Sub

 

[bsweet0us]

You're welcome, glad to help & thanks for the feedback.
And on a bigger data size you might want to increase the limit of the loop in this part:

qq = qq + 1: If qq > 20000 Then MsgBox "Endless loop": Exit Sub

I changed it to 200,000!

 

[Akuini]

Sorry, after doing some test again, actually the added line

 If coll.Count = 2 Then va(uva, 1) = coll(1): va(uva, 2) = coll(2): Exit Do

could generate duplicate pair. For instance if the remaining names are Yadier & Zoe, both names already exist in BLIND DOUBLES.
So I think the best way is if the endless loop happens then you need to restart the sub.
So, just use your version in post#9. Just add a message in this line:
qq = qq + 1: If qq > 200000 Then MsgBox "Endless loop. Restart the Sub": Exit Sub

 

[bradshk]

Sorry to ask a question on an old thread but thought I would give it a try. I am using the code that is in Post #9 to pick random pairs of names without duplicating for a pool tournament. The code works but the format. is not easy for me to manage in my use case. The issue is the list of previous pairs (to not re-pair) in Column C is vertical, but I would like for the code to read them horizontal. For example it reads the first previous pair from C5 and C6. I would like to have it read the previous pairs from C5 and D5 and down. Thanks for any help.