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

bsweet0us

New Member
Joined
Apr 12, 2008
Messages
30
VBA Code:
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

New Member
Joined
Apr 12, 2008
Messages
30
Why do you remove this line?
Rich (BB code):
 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.
 
Last edited:

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.

Akuini

Well-known Member
Joined
Feb 1, 2016
Messages
3,641
Office Version
  1. 365
Platform
  1. Windows
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:
Rich (BB code):
qq = qq + 1: If qq > 20000 Then MsgBox "Endless loop": Exit Sub
 

bsweet0us

New Member
Joined
Apr 12, 2008
Messages
30
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:
Rich (BB code):
qq = qq + 1: If qq > 20000 Then MsgBox "Endless loop": Exit Sub
I changed it to 200,000!
 

Akuini

Well-known Member
Joined
Feb 1, 2016
Messages
3,641
Office Version
  1. 365
Platform
  1. Windows
Sorry, after doing some test again, actually the added line
Rich (BB code):
 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
 
Learn Excel from Bill Jelen

Understanding data is crucial, and the easiest place to start is with Microsoft Excel.

Forum statistics

Threads
1,151,699
Messages
5,766,002
Members
425,322
Latest member
galaxy6623top

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top