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!

 

[Akuini]

Could you post an example? preferably by using the XL2BB tool.

 

[bsweet0us]

Blind Doubles.xlsm
	A
6	Alice
7	Bob
8	Carl
9	Dave
10	Edith
11	Frank
12	George
13	Harry
14	Iris
15	John
16	Kelly
17	Larry
18	Mike
19	Nolan
20	Opal
21	Paul
22	Quentin
23	Ralph
24	Sam
25	Tom
26	Ursula
27	Violet
28	Wayne
29	Xavier
30	Yadier
31	Zoe
helper blind

Cell Formulas
Range	Formula
A6:A31	A6	=IF('BLIND ENTRANTS'!A6="","",'BLIND ENTRANTS'!A6)

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

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.

 

[Akuini]

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:

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
	A	B	C	D	E	F	G	H	I	J	K	L	M	N
6	Alice												Wayne	Ursula
7	Bob												Quentin	Harry
8	Carl												Frank	Opal
9	Dave												Larry	Tom
10	Edith												Xavier	Kelly
11	Frank												Edith	Violet
12	George												Nolan	Sam
13	Harry												Alice	Dave
14	Iris												Paul	George
15	John
16	Kelly
17	Larry
18	Mike
19	Nolan
20	Opal
21	Paul
22	Quentin
23	Ralph
24	Sam
25	Tom
26	Ursula
27	Violet
28	Wayne
29	Xavier
30	Yadier
31	Zoe
Sheet1

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

Edited: I edited the declaration part

 

[bsweet0us]

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...

 

[Akuini]

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:

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

 

[bsweet0us]

If Wayne-Tom already exists then we can't have Wayne-Tom or Tom-Wayne, right?
Ok, try this one:

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.

 

[Akuini]

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

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

 

[bsweet0us]

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.

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

 

[Akuini]

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.