Generate unique random team groupings multiple times

[starl]

I have 2 teams - Team A and Team B. I need to randomly group one player from each team. These groupings need to happen multiple times, and none of the groupings can be repeated between those times. Nor can a player be listed more than once within a week

So in my example below, columns A & B are my teams and players. Columns D:F show sample groupings (D&E are not very random, F is just a formula I threw in, but as you see, it doesn't always work). F10 and F25 are highlighted in red because that's the same group up in two different weeks and that's not allowed. Nor would a repeat of a group within a week or a single player listed twice in a week (F7&F18). I don't care if the solution is a formula or code. Week1 & Week2 are not very random and using that logic to generate the rest of the weeks (I need 10 total), would not be very random.

I'm showing my formula because I had it there, but it isn't what I expect the solution to be (especially since it would only generate a single week and there's no comparison to previous weeks to ensure non-duplicates)

bellevue.xlsx
	A	B	C	D	E	F
1	Team A	Team B		Week 1	Week2	Week3
2	B1	A1		B1-A1	B1-A2	B14-A23
3	B2	A2		B2-A2	B2-A3	B8-A26
4	B3	A3		B3-A3	B3-A4	B16-A3
5	B4	A4		B4-A4	B4-A5	B4-A14
6	B5	A5		B5-A5	B5-A6	B3-A15
7	B6	A6		B6-A6	B6-A7	B22-A16
8	B7	A7		B7-A7	B7-A8	B19-A7
9	B8	A8		B8-A8	B8-A9	B7-A6
10	B9	A9		B9-A9	B9-A10	B24-A25
11	B10	A10		B10-A10	B10-A11	B16-A21
12	B11	A11		B11-A11	B11-A12	B7-A19
13	B12	A12		B12-A12	B12-A13	B3-A23
14	B13	A13		B13-A13	B13-A14	B10-A26
15	B14	A14		B14-A14	B14-A15	B4-A11
16	B15	A15		B15-A15	B15-A16	B12-A19
17	B16	A16		B16-A16	B16-A17	-A9
18	B17	A17		B17-A17	B17-A18	B22-A4
19	B18	A18		B18-A18	B18-A19	B13-A18
20	B19	A19		B19-A19	B19-A20	B23-A11
21	B20	A20		B20-A20	B20-A21	B15-A25
22	B21	A21		B21-A21	B21-A22	B8-A19
23	B22	A22		B22-A22	B22-A23	-A22
24	B23	A23		B23-A23	B23-A24	B24-A19
25	B24	A24		B24-A24	B24-A25	B2-
26	B25	A25		B25-A25	B25-A26	B4-A18
27	B26	A26		B26-A26	B26-A1	B9-A6
Sheet1

Cell Formulas
Range	Formula
F2	F2	=OFFSET($A$1,RANDBETWEEN(2,27),0)&"-" &OFFSET($B$1,RANDBETWEEN(2,27),0)

 

[rlv01]

Maybe something like this.

Sub MakePairings()
    Dim I As Long, J As Long
    Dim R As Range, rngColData As Range
    Dim S As String
    Dim WS As Worksheet

    Set WS = ActiveSheet
    With WS
        Set rngColData = .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
    End With

    Application.ScreenUpdating = False
    rngColData.Offset(0, 2).Resize(, 3).ClearContents
    For Each R In rngColData
        For J = 2 To 4
            S = NewCombo(rngColData.Offset(0, J))

            I = 0
            Do While Not rngColData.Offset(0, J).Find(What:=S, LookAt:=xlWhole) Is Nothing
                S = NewCombo(rngColData.Offset(0, J))
                I = I + 1
                If I > 100 Then
                    Exit Sub                          'emergency exit
                End If
            Loop
            R.Offset(0, J).Value = S
        Next J
    Next R
    rngColData.Offset(0, 2).Resize(, 3).Replace What:="$", Replacement:="", LookAt:=xlPart
    Application.ScreenUpdating = True
End Sub

Function NewCombo(rngColData As Range) As String
    Dim I As Long
    Dim Found As Range
    Dim P1 As String, P2 As String, S As String

    I = 0
    Do
        Set Found = Nothing
        P1 = "A" & Application.WorksheetFunction.RandBetween(1, 26) & "$"

        I = I + 1
        If I > 200 Then
            Exit Function                             'emergency exit
        End If
        Set Found = rngColData.Find(What:=P1, LookAt:=xlPart)
    Loop Until Found Is Nothing

    I = 0
    Do
        Set Found = Nothing
        P2 = "B" & Application.WorksheetFunction.RandBetween(1, 26) & "$"

        I = I + 1
        If I > 200 Then
            Exit Function                             'emergency exit
        End If
        Set Found = rngColData.Find(What:=P2, LookAt:=xlPart)
    Loop Until Found Is Nothing

    S = P1 & "-" & P2
    NewCombo = S
End Function

tmpzl.xlsm
	A	B	C	D	E
1	Team A	Team B	Week 1	Week2	Week3
2	B1	A1	A21-B6	A3-B14	A22-B25
3	B2	A2	A16-B8	A6-B2	A13-B2
4	B3	A3	A6-B2	A13-B20	A2-B24
5	B4	A4	A7-B25	A16-B17	A5-B14
6	B5	A5	A13-B12	A19-B26	A21-B9
7	B6	A6	A22-B4	A5-B12	A7-B10
8	B7	A7	A11-B16	A2-B3	A8-B11
9	B8	A8	A3-B3	A23-B15	A3-B23
10	B9	A9	A12-B9	A10-B9	A15-B1
11	B10	A10	A25-B17	A11-B16	A20-B7
12	B11	A11	A15-B26	A12-B10	A25-B16
13	B12	A12	A8-B13	A1-B13	A9-B22
14	B13	A13	A2-B21	A15-B24	A11-B26
15	B14	A14	A19-B11	A7-B21	A16-B3
16	B15	A15	A24-B10	A14-B18	A24-B6
17	B16	A16	A5-B15	A21-B11	A12-B13
18	B17	A17	A23-B7	A18-B8	A14-B19
19	B18	A18	A9-B14	A22-B7	A10-B8
20	B19	A19	A17-B22	A17-B5	A1-B15
21	B20	A20	A26-B23	A4-B22	A26-B17
22	B21	A21	A4-B19	A26-B1	A19-B4
23	B22	A22	A20-B1	A9-B4	A18-B5
24	B23	A23	A1-B24	A24-B6	A6-B21
25	B24	A24	A14-B5	A20-B19	A4-B20
26	B25	A25	A18-B18	A8-B23	A17-B18
27	B26	A26	A10-B20	A25-B25	A23-B12
Sheet1

 

[starl]

Thank for looking at this @rlv01, but the solution does have some duplicates between weeks (in red)

Book1
	A	B	C	D	E
1	Team A	Team B	Week 1	Week2	Week3
2	B1	A1	A21-B6	A3-B14	A22-B25
3	B2	A2	A16-B8	A6-B2	A13-B2
4	B3	A3	A6-B2	A13-B20	A2-B24
5	B4	A4	A7-B25	A16-B17	A5-B14
6	B5	A5	A13-B12	A19-B26	A21-B9
7	B6	A6	A22-B4	A5-B12	A7-B10
8	B7	A7	A11-B16	A2-B3	A8-B11
9	B8	A8	A3-B3	A23-B15	A3-B23
10	B9	A9	A12-B9	A10-B9	A15-B1
11	B10	A10	A25-B17	A11-B16	A20-B7
12	B11	A11	A15-B26	A12-B10	A25-B16
13	B12	A12	A8-B13	A1-B13	A9-B22
14	B13	A13	A2-B21	A15-B24	A11-B26
15	B14	A14	A19-B11	A7-B21	A16-B3
16	B15	A15	A24-B10	A14-B18	A24-B6
17	B16	A16	A5-B15	A21-B11	A12-B13
18	B17	A17	A23-B7	A18-B8	A14-B19
19	B18	A18	A9-B14	A22-B7	A10-B8
20	B19	A19	A17-B22	A17-B5	A1-B15
21	B20	A20	A26-B23	A4-B22	A26-B17
22	B21	A21	A4-B19	A26-B1	A19-B4
23	B22	A22	A20-B1	A9-B4	A18-B5
24	B23	A23	A1-B24	A24-B6	A6-B21
25	B24	A24	A14-B5	A20-B19	A4-B20
26	B25	A25	A18-B18	A8-B23	A17-B18
27	B26	A26	A10-B20	A25-B25	A23-B12
Sheet1

 

[starl]

But - after reviewing your code, I have a couple of ideas how this can be resolved! Thank you - I didn't know where to start, but you've given me something.

 

[rlv01]

Sub MakePairings()
    Dim I As Long, J As Long
    Dim R As Range, rngColData As Range, rngSearch As Range
    Dim S As String
    Dim WS As Worksheet

    Set WS = ActiveSheet
    With WS
        Set rngColData = .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
    End With

    Application.ScreenUpdating = False
    Set rngSearch = rngColData.Offset(0, 2).Resize(, 3)
    rngSearch.ClearContents
    For Each R In rngColData
        For J = 2 To 4
            S = NewCombo(rngColData.Offset(0, J))

            I = 0
            Do While Not rngSearch.Find(What:=S, LookAt:=xlWhole) Is Nothing
                S = NewCombo(rngColData.Offset(0, J))
                I = I + 1
                If I > 300 Then
                    Call MakePairings
                    Exit Sub                          'emergency exit
                End If
            Loop
            R.Offset(0, J).Value = S
        Next J
    Next R
    rngSearch.Replace What:="$", Replacement:="", LookAt:=xlPart
    Application.ScreenUpdating = True
End Sub

FWIW, your 'no duplicate pairings' is not going to hold up over more than say 3-4 weeks. The team sizes are too small. At some point you will have to switch to a non-random assignment system.

 

[starl]

FWIW, your 'no duplicate pairings' is not going to hold up over more than say 3-4 weeks. The team sizes are too small. At some point you will have to switch to a non-random assignment system.

hmm - I'll keep that in mind. thanks!