Unique groups of two numbers, all numbers in a unique group

[dtaylor646]

Hello everyone,

Though some other posts have had similar solutions, I want to pair a list of unique identifiers to others with each pairing unique for each month. April has #1 with #3 and necessarily #3 with #1 The first three pairings were manual and would like a formula to generate the other pairings for other months, where the pairings do not repeat from the previous months' pairs. Thank you for any and all help!

Identifier	April	May	June	July
1	3	2	4	[formula here]
2	4	1	3
3	1	4	2
4	2	3	1
5	7	6	8
6	8	5	14
7	5	8	20
8	6	7	5
9	11	10	12
10	12	9	11
11	9	12	10
12	10	11	9
13	19	14	15
14	20	13	6
15	17	16	13
16	18	15	17
17	15	18	16
18	16	17	19
19	13	20	18
20	14	19	7

<tbody>
</tbody>

 

[shg]

Welcome to the board.

Provide several examples that illustrate the logic.

 

[dtaylor646]

Welcome to the board.

Provide several examples that illustrate the logic.

From the above grid, let's say #7 is selected to be paired with identifier #1 in July. In that case...on the seventh line down...identifier #7 must be paired with #1 since that was the number chosen as a pair. So it looks like what I am seeking if a nested formula that generates a 'random' number that is not the identifier or previous pairings (for #1 , not #1 , 3, 2, or 4]...but is recursive that if a number is selected above, the pairing is forced in the cell. The last nuance of logic is that all the numbers need to be uniquely paired. From the above example...if numbers 1-18 are assigned to identifiers #1 -18 in July...this cannot work since #s 19 and #20 were already paired together in May.

Hopefully explaining the restrictions helps clarify the solution I am trying to find.

 

[shg]

I don't have a clue what you're trying to do, sorry.

 

[Eric W]

If I read the request right, the OP wants a random list of the numbers 1-20 in the July column, with the proviso that no numbers in any row are duplicated.

If that's correct, I think a formula might be a bit complicated. I have written a macro that should create such a list. Given the layout in post # 1, with the upper right corner being A1, try this:

Open a copy of your workbook. Press Alt-F11 to open the VBA editor. From the menu, select Insert > Module. In the window that opens, paste this:

Sub NewGroup()
Dim NewCol(1 To 20, 1 To 1) As Long, i As Long, j As Long, dict As Object
Dim Ctr1 As Long, Ctr2 As Long, MyData As Variant, c As Long, LastCol As Long

    Ctr1 = 0
    LastCol = Range("A2").End(xlToRight).Column
    MyData = Range("A2").Resize(20, LastCol).Value
    Set dict = CreateObject("Scripting.Dictionary")
    
BigLoop:
    Erase NewCol
    For c = 1 To 20
        dict.RemoveAll
        Ctr2 = 0
        For i = 1 To 20
            For j = 1 To LastCol
                If MyData(c, j) = i Then GoTo NextI:
            Next j
            For j = 1 To c - 1
                If NewCol(j, 1) = i Then GoTo NextI:
            Next j
            Ctr2 = Ctr2 + 1
            dict.Add Ctr2, i
NextI:
        Next i
        If Ctr2 = 0 Then
            If Ctr1 > 1000 Then
                MsgBox "Could not find a solution after 1000 tries"
                Exit Sub
            End If
            Ctr1 = Ctr1 + 1
            GoTo BigLoop:
        End If
        NewCol(c, 1) = dict(Int(Rnd() * Ctr2) + 1)
    Next c
    
    Range("A2:A21").Offset(, LastCol).Value = NewCol
        
End Sub

Press Alt-Q to close the editor. From Excel, press Alt-F8 to open the macro selector. Select NewGroup and click Run. You may run it again to get another column. Or delete columns B:D to start anew.

The code is rough and probably can be cleaned up some, but it seems to work. Let us know if it's what you need.

 

[Marcelo Branco]

Eric,

I tried your code (results in gray area), but i *think* these are not the desired results.
If i understood correctly the macro should generate pairs, that is:
If Id 1 --> 13 then Id 13 --> 1; If Id 2 --> 6 then Id 6 --> 2 and so on (observe columns April, May and June)

	A​	B​	C​	D​	E​
1​	Identifier​	April​	May​	June​	July​
2​	1​	3​	2​	4​	13​
3​	2​	4​	1​	3​	6​
4​	3​	1​	4​	2​	20​
5​	4​	2​	3​	1​	15​
6​	5​	7​	6​	8​	1​
7​	6​	8​	5​	14​	11​
8​	7​	5​	8​	20​	3​
9​	8​	6​	7​	5​	4​
10​	9​	11​	10​	12​	18​
11​	10​	12​	9​	11​	7​
12​	11​	9​	12​	10​	2​
13​	12​	10​	11​	9​	8​
14​	13​	19​	14​	15​	10​
15​	14​	20​	13​	6​	9​
16​	15​	17​	16​	13​	19​
17​	16​	18​	15​	17​	14​
18​	17​	15​	18​	16​	5​
19​	18​	16​	17​	19​	12​
20​	19​	13​	20​	18​	16​
21​	20​	14​	19​	7​	17​
22​

<tbody>
</tbody>

I tried different formulas without success
Tough one!

M.

 

[Eric W]

Hmm, in examining the original examples, I think you're right. I thought it wouldn't be too hard to update my macro, but it's proving tougher than I thought. I'll think upon it a bit more.

 

[Marcelo Branco]

This (i think) would be a possible result

	A​	B​	C​	D​	E​
1​	Identifier​	April​	May​	June​	July​
2​	1​	3​	2​	4​	18​
3​	2​	4​	1​	3​	6​
4​	3​	1​	4​	2​	14​
5​	4​	2​	3​	1​	8​
6​	5​	7​	6​	8​	12​
7​	6​	8​	5​	14​	2​
8​	7​	5​	8​	20​	10​
9​	8​	6​	7​	5​	4​
10​	9​	11​	10​	12​	20​
11​	10​	12​	9​	11​	7​
12​	11​	9​	12​	10​	16​
13​	12​	10​	11​	9​	5​
14​	13​	19​	14​	15​	17​
15​	14​	20​	13​	6​	3​
16​	15​	17​	16​	13​	19​
17​	16​	18​	15​	17​	11​
18​	17​	15​	18​	16​	13​
19​	18​	16​	17​	19​	1​
20​	19​	13​	20​	18​	15​
21​	20​	14​	19​	7​	9​
22​

I achieved this with a formula after many F9 to generate a result without any error
Of course a formula that generates errors and requires many trials is not a proper (decent) solution!

M.

 

[Eric W]

OK, this macro pairs up the random selections:

Sub NewGroup()
Dim NewCol(1 To 20, 1 To 1) As Long, i As Long, j As Long, MyOptions(1 To 20) As Long
Dim Ctr1 As Long, Ctr2 As Long, MyData As Variant, c As Long, LastCol As Long
Dim UsedRows(0 To 20) As Object, x As Long, y As Long

    Ctr1 = 0
    LastCol = Range("A2").End(xlToRight).Column
    MyData = Range("A2").Resize(20, LastCol).Value
    Set UsedRows(0) = CreateObject("Scripting.Dictionary")
    For i = 1 To 20
        Set UsedRows(i) = CreateObject("Scripting.Dictionary")
        For j = 1 To LastCol
            UsedRows(i).Add CLng(MyData(i, j)), 1
        Next j
    Next i
    
BigLoop:
    Erase NewCol
    UsedRows(0).RemoveAll
    For c = 1 To 20
        If NewCol(c, 1) <> 0 Then GoTo NextC:
        Erase MyOptions
        Ctr2 = 0
        For i = 1 To 20
            If Not UsedRows(c).exists(i) And Not UsedRows(0).exists(i) Then
                Ctr2 = Ctr2 + 1
                MyOptions(Ctr2) = i
            End If
        Next i
        If Ctr2 = 0 Then GoTo ChkCtr2:
        For i = 1 To Ctr2
            x = Int(Rnd() * (Ctr2 + 1 - i) + 1)
            y = MyOptions(x)
            If NewCol(y, 1) = 0 Then
                NewCol(c, 1) = y
                NewCol(y, 1) = c
                UsedRows(0).Add CLng(c), 1
                UsedRows(0).Add CLng(y), 1
                GoTo NextC:
            End If
            MyOptions(i) = MyOptions(Ctr2 + 1 - i)
        Next i

ChkCtr2:
        If Ctr1 > 1000 Then
            MsgBox "Could not find a solution after 1000 tries"
            Exit Sub
        End If
        Ctr1 = Ctr1 + 1
        GoTo BigLoop:
NextC:
    Next c
    
    Range("A2:A21").Offset(, LastCol).Value = NewCol
        
End Sub

It's an iterative solution, but it seems to work fast up to 20 columns.

 

[Marcelo Branco]

Eric,

The formula i created requires some F9, not many, to generate correct results.

Array formula in E2 copied down
=IF(COUNTIF(E$1:E1,$A2),INDEX($A$1:$A1,MATCH($A2,E$1:E1,0)),SMALL(IF(ISNA(MATCH($A$2:$A$21,$A2:D2,0)),IF(ISNA(MATCH($A$2:$A$21,E$1:E1,0)),IF(ISNA(MATCH($A$2:$A$21,$A$1:A1,0)),$A$2:$A$21))),RANDBETWEEN(1,MAX(1,20-SUMPRODUCT(1/COUNTIF($A$2:D2,$A$2:D2))-SUM(IF(COUNTIF($A$2:D2,E$1:E1)=0,1))+1))))
Ctrl+Shift+Enter

M.