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

bsweet0us

New Member
Joined
Apr 12, 2008
Messages
38
Office Version
  1. 365
Platform
  1. Windows
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!
 

Excel Facts

Formula for Yesterday
Name Manager, New Name. Yesterday =TODAY()-1. OK. Then, use =YESTERDAY in any cell. Tomorrow could be =TODAY()+1.
Could you post an example? preferably by using the XL2BB tool.
 
Upvote 0
Cell Formulas
RangeFormula
A6:A31A6=IF('BLIND ENTRANTS'!A6="","",'BLIND ENTRANTS'!A6)


Blind Doubles.xlsm
C
5John
6Mike
7Yadier
8Zoe
9Ralph
10John
11Mike
12Bob
13Carl
14Iris
BLIND DOUBLES


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

Hopefully this works. The first mini-sheet is the data that will be randomized into pairs. The second mini-sheet is the pairs that already exist. The code will take the data from the first mini-sheet and randomize them into pairs in the "M6" and "N6" ranges down the column. (The "PlaceTeams" sub simply copies the data from the M and N columns and places them in the C column on the second mini-sheet on top of each other as opposed to side by side).

What I need to accomplish is to check each of those random pairings to ensure they don't match any of the existing pairings. If any pairs match, re-randomize. Alternatively, I could utilize a different sub that somehow notates the pairs from the second mini-sheet and reandomizes the list from the first mini-sheet excluding those pre-existing pairs.

I appreciate your assistance and I'll provide any additional documentation that will be helpful.
 
Upvote 0
My understanding of the requirements are:
1. You can't use names that already exist in the second sheet.
2. A name can only exist in one pair.

Try:
VBA Code:
Sub RandomPairing()
Dim coll As New Collection, va, vb, z, a, b
Dim i As Long, x As Long, y As Long, qq As Long
Dim d As Object

With Sheets("sheet2")
    vb = .Range("A6", .Cells(.Rows.Count, "A").End(xlUp))
End With

Set d = CreateObject("scripting.dictionary"): d.CompareMode = vbTextCompare

    For i = 1 To UBound(vb, 1)
        d(vb(i, 1)) = Empty
    Next

With Sheets("sheet1")
    vb = .Range("A6", .Cells(.Rows.Count, "A").End(xlUp))
End With

For Each z In vb
     If Not d.Exists(z) Then coll.Add z
Next

    ReDim va(1 To coll.Count / 2, 1 To 2)
i = 0
    Do
        x = WorksheetFunction.RandBetween(1, coll.Count)
        y = WorksheetFunction.RandBetween(1, coll.Count)
        a = coll(x): b = coll(y)
        If x <> y Then
            If Not d.Exists(a) And Not d.Exists(b) Then
                d(a) = Empty: d(b) = Empty
                i = i + 1
                va(i, 1) = a:  va(i, 2) = b
               
                If x > y Then
                    coll.Remove (x): coll.Remove (y)
                Else
                    coll.Remove (y): coll.Remove (x)
                End If
            End If
        End If
        qq = qq + 1: If qq > 20000 Then MsgBox "Endless loop": Exit Sub
    Loop Until i = UBound(va, 1) Or coll.Count = 1

Sheets("sheet1").Range("M6").Resize(UBound(va, 1), 2) = va

End Sub

bsweet0us - 1.xlsm
ABCDEFGHIJKLMN
6AliceWayneUrsula
7BobQuentinHarry
8CarlFrankOpal
9DaveLarryTom
10EdithXavierKelly
11FrankEdithViolet
12GeorgeNolanSam
13HarryAliceDave
14IrisPaulGeorge
15John
16Kelly
17Larry
18Mike
19Nolan
20Opal
21Paul
22Quentin
23Ralph
24Sam
25Tom
26Ursula
27Violet
28Wayne
29Xavier
30Yadier
31Zoe
Sheet1


bsweet0us - 1.xlsm
A
6John
7Mike
8Yadier
9Zoe
10Ralph
11John
12Mike
13Bob
14Carl
15Iris
Sheet2


Edited: I edited the declaration part
 
Upvote 0
My understanding of the requirements are:
1. You can't use names that already exist in the second sheet.
2. A name can only exist in one pair.
Not exactly.

1. All the names in column A have to be paired with another name in column A. In this example, we MUST end up with 13 pairings (because we have 26 names).
2. No. All the names on the second sheet have to remain and we need to generate 13 UNIQUE pairings taking into account the pairings that already exist in the second sheet.

So, in this example, the second sheet has John and Mike as a pairing (A6 & A7) and also has Ralph and John as a pairing (A10 and A11). John must therefore be paired up with someone from the first sheet other than Mike or Ralph.

Long story short, we need 13 pairings from the first sheet that don't exist on the second sheet.

I know this is cumbersome, but I think this latest message is very close...
 
Upvote 0
1. All the names in column A have to be paired with another name in column A. In this example, we MUST end up with 13 pairings (because we have 26 names).
2. No. All the names on the second sheet have to remain and we need to generate 13 UNIQUE pairings taking into account the pairings that already exist in the second sheet.
If Wayne-Tom already exists then we can't have Wayne-Tom or Tom-Wayne, right?
Ok, try this one:
VBA Code:
Sub RandomPairing2()
Dim coll As New Collection, va, vb, z, a, b
Dim i As Long, x As Long, y As Long, qq As Long
Dim d As Object

With Sheets("sheet2")
    vb = .Range("A6", .Cells(.Rows.Count, "A").End(xlUp))
End With

Set d = CreateObject("scripting.dictionary")
d.CompareMode = vbTextCompare

    For i = 1 To UBound(vb, 1) Step 2
        d(vb(i, 1) & " " & vb(i + 1, 1)) = Empty
        d(vb(i + 1, 1) & " " & vb(i, 1)) = Empty
    Next

With Sheets("sheet1")
    vb = .Range("A6", .Cells(.Rows.Count, "A").End(xlUp))
End With

For Each z In vb
        coll.Add z
Next

i = 0
    ReDim va(1 To UBound(vb, 1) / 2, 1 To 2)
       
    Do
        x = WorksheetFunction.RandBetween(1, coll.Count)
        y = WorksheetFunction.RandBetween(1, coll.Count)
        tx = coll(x) & " " & coll(y)
        If x <> y Then
            If Not d.Exists(tx) Then
                d(tx) = Empty
                i = i + 1
                va(i, 1) = coll(x)
                va(i, 2) = coll(y)
                
                If x > y Then
                    coll.Remove (x): coll.Remove (y)
                Else
                    coll.Remove (y): coll.Remove (x)
                End If
            End If
        End If
        qq = qq + 1: If qq > 20000 Then MsgBox "Endless loop nih": Exit Sub
    Loop Until i = UBound(va, 1)

Range("M6").Resize(UBound(va, 1), 2) = va
End Sub
 
Upvote 0
If Wayne-Tom already exists then we can't have Wayne-Tom or Tom-Wayne, right?
Ok, try this one:
VBA Code:
Sub RandomPairing2()
Dim coll As New Collection, va, vb, z, a, b
Dim i As Long, x As Long, y As Long, qq As Long
Dim d As Object

With Sheets("sheet2")
    vb = .Range("A6", .Cells(.Rows.Count, "A").End(xlUp))
End With

Set d = CreateObject("scripting.dictionary")
d.CompareMode = vbTextCompare

    For i = 1 To UBound(vb, 1) Step 2
        d(vb(i, 1) & " " & vb(i + 1, 1)) = Empty
        d(vb(i + 1, 1) & " " & vb(i, 1)) = Empty
    Next

With Sheets("sheet1")
    vb = .Range("A6", .Cells(.Rows.Count, "A").End(xlUp))
End With

For Each z In vb
        coll.Add z
Next

i = 0
    ReDim va(1 To UBound(vb, 1) / 2, 1 To 2)
      
    Do
        x = WorksheetFunction.RandBetween(1, coll.Count)
        y = WorksheetFunction.RandBetween(1, coll.Count)
        tx = coll(x) & " " & coll(y)
        If x <> y Then
            If Not d.Exists(tx) Then
                d(tx) = Empty
                i = i + 1
                va(i, 1) = coll(x)
                va(i, 2) = coll(y)
               
                If x > y Then
                    coll.Remove (x): coll.Remove (y)
                Else
                    coll.Remove (y): coll.Remove (x)
                End If
            End If
        End If
        qq = qq + 1: If qq > 20000 Then MsgBox "Endless loop nih": Exit Sub
    Loop Until i = UBound(va, 1)

Range("M6").Resize(UBound(va, 1), 2) = va
End Sub
We're on the verge of a breakthrough...

You're correct in assuming Wayne/Tom is equivalent to Tom/Wayne.

I plugged the code in and ran it, just not sure which sheet is sheet1 and sheet2 in the code. One sheet is the list of entrants (called "helper blind" in my workbook and beginning in A6 and continuing down the column) and the pairings are located on sheet "BLIND DOUBLES" and begin in cell C5 and continuing down.

I had some pairings when I ran this as "Tom/Tom" for instance, but that might be because I got the sheet names off when translating. Also, the resize needs to occur in the "helper blind" sheet and couldn't figure out how to determine which sheet that last line of code references.
 
Upvote 0
and the pairings are located on sheet "BLIND DOUBLES" and begin in cell C5 and continuing down
Sorry, I thougt it was C6.
Try this one
VBA Code:
Sub RandomPairing2()
Dim coll As New Collection, va, vb, z, a, b
Dim i As Long, x As Long, y As Long, qq As Long
Dim d As Object

'the pairings are located on sheet "BLIND DOUBLES" and begin in cell C5 and continuing down
With Sheets("BLIND DOUBLES")
    vb = .Range("A5", .Cells(.Rows.Count, "A").End(xlUp))
End With

Set d = CreateObject("scripting.dictionary")
d.CompareMode = vbTextCompare

    For i = 1 To UBound(vb, 1) Step 2
        d(vb(i, 1) & " " & vb(i + 1, 1)) = Empty
        d(vb(i + 1, 1) & " " & vb(i, 1)) = Empty
    Next

With Sheets("helper blind")
    vb = .Range("A6", .Cells(.Rows.Count, "A").End(xlUp))
End With

For Each z In vb
        coll.Add z
Next

i = 0
    ReDim va(1 To UBound(vb, 1) / 2, 1 To 2)
    uva = UBound(va, 1)
    Do
        x = WorksheetFunction.RandBetween(1, coll.Count)
        y = WorksheetFunction.RandBetween(1, coll.Count)
        tx = coll(x) & " " & coll(y)
        If x <> y Then
            If Not d.Exists(tx) Then
                d(tx) = Empty
                i = i + 1
                va(i, 1) = coll(x)
                va(i, 2) = coll(y)
                
                If x > y Then
                    coll.Remove (x): coll.Remove (y)
                Else
                    coll.Remove (y): coll.Remove (x)
                End If
            End If
        End If
        If coll.Count = 2 Then va(uva, 1) = coll(1): va(uva, 2) = coll(2): Exit Do
        
        qq = qq + 1: If qq > 200000 Then MsgBox "Endless loop": Exit Sub
    Loop Until i = uva

Sheets("helper blind").Range("M6").Resize(UBound(va, 1), 2) = va
End Sub
 
Upvote 1
Solution
Not gonna lie, this is absolutely incredible! In between the time I posted my reply and got your reply, I researched dictionaries in Excel VBA and immediately knew this was the right path. I made some minor modifications to account for some formulas in cells below where the lists end to get the proper counts, but it worked with one test run, and stepping through what it was doing I am certain it will work for a larger sample size. Thank you so much for putting this together and expanding my knowledge, if only slightly. I don't know that I could tackle dictionaries head-on right now, but the methodology you put forth makes sense and I was able to make sense of it. Here's the final code with the minor adjustments I made.

VBA Code:
Sub RandomPairing2()
Dim coll As New Collection, va, vb, z, a, b
Dim i As Long, x As Long, y As Long, qq As Long, lastrow As Long
Dim d As Object

With Sheets("BLIND DOUBLES")

    lastrow = .Range("C6:C50").Find("*", searchdirection:=xlPrevious, searchorder:=xlByColumns, LookIn:=xlValues).Row
    vb = .Range("C5", "C" & lastrow)
End With

Set d = CreateObject("scripting.dictionary")
d.CompareMode = vbTextCompare

    For i = 1 To UBound(vb, 1) Step 2
        d(vb(i, 1) & " " & vb(i + 1, 1)) = Empty
        d(vb(i + 1, 1) & " " & vb(i, 1)) = Empty
    Next

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

For Each z In vb
        coll.Add z
Next

i = 0
    ReDim va(1 To UBound(vb, 1) / 2, 1 To 2)
       
    Do
        x = WorksheetFunction.RandBetween(1, coll.Count)
        y = WorksheetFunction.RandBetween(1, coll.Count)
        tx = coll(x) & " " & coll(y)
        If x <> y Then
            If Not d.Exists(tx) Then
                d(tx) = Empty
                i = i + 1
                va(i, 1) = coll(x)
                va(i, 2) = coll(y)
                
                If x > y Then
                    coll.Remove (x): coll.Remove (y)
                Else
                    coll.Remove (y): coll.Remove (x)
                End If
            End If
        End If
        qq = qq + 1: If qq > 20000 Then MsgBox "Endless loop nih": Exit Sub
    Loop Until i = UBound(va, 1)
    
With Sheets("helper blind")
Range("M6").Resize(UBound(va, 1), 2) = va
End With

End Sub
 
Upvote 0
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.
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,208
Members
448,554
Latest member
Gleisner2

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
Back
Top