Give random unique set of 9 pairs

MaxTrax · Apr 20, 2016

Hi People,

I have a set of 58 pairs (I’m using paired numbers here but they could be anything).

I am hoping someone can help in providing a VBA macro or formula to complete the following:

The result should give a unique random set of 9 pairs in any order with of course no repeats of pairs.
Eg 1: This result would be correct. 5/10, 20/30, 110/140, 70/ 80, 150/180, 260/270, 40/50, 200/230, 190/220 (A set of 9 unique pairs)

Eg 2: This result would be incorrect. 30/60, 40/50, 40/70 (as both contain 40), 140/170, 5/20, 5/30 (as both contain 5), 100/110, 20/30, 250/280 (Not a set of 9 unique pairs)

The correct formula will be copied over many cells to give a new random set of 9 in each. It is quite possible some *new sets of 9* in different cells would repeat and that is ok.

Here are the 58 pairs.
5/10, 5/20, 5/30, 10/20, 10/40, 20/30, 20/50, 30/60, 40/50, 40/70, 50/60, 50/80, 60/90, 70/80, 70/100, 80/90, 80/110, 90/120, 100/110, 100/130, 110/120, 110/140, 120/150, 130/140, 130/160, 140/150, 140/170, 150/180, 160/170, 160/190, 170/180, 170/200, 180/210, 190/200, 190/220, 200/210, 200/230, 210/240, 220/230, 220/250, 230/240, 230/260, 240/270, 250/260, 250/280, 260/270, 260/290, 270/300, 280/290, 280/310, 290/300, 290/320, 300/330, 310/320, 310/340, 320/330, 320/350, 330/360

Thanks to anybody who helps.

MaxTrax

ask2tsp · Apr 22, 2016

A possible solution.
I created 2 sheets. "Pairs" holds the 58 pairs in A1:B58. "Sets" has a list of cells where a block of 9 pairs must be build. When the macro setsOf9pairs runs these blocks are created.

Sets

	A	B	C	D	E	F	G	H	I	J
1	C1		40	50		10	20		5	30
2	F1		50	80		40	70		20	50
3	I1		60	90		50	80		50	60
4	C11		80	110		120	150		60	90
5	F11		90	120		200	210		130	140
6	I11		110	140		220	250		140	170
7			170	180		250	260		170	180
8			190	200		260	270		180	210
9			290	300		320	330		230	260
10
11			5	10		20	50		10	20
12			20	30		30	60		40	70
13			140	150		80	110		80	110
14			200	230		110	120		120	150
15			230	240		130	160		160	190
16			250	260		160	170		220	230
17			260	290		170	200		260	270
18			300	330		210	240		300	330
19			330	360		310	340		320	350

Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4.8

Code:

Option Explicit

Sub setsOf9pairs()
    Dim tl As Range
    Dim sets As Worksheet
    
    Set sets = ThisWorkbook.Worksheets("Sets")
    For Each tl In sets.Range("A1").CurrentRegion
        buildUniqueSet sets.Range(tl.Value)
    Next tl

End Sub

Sub buildUniqueSet(topLeft As Range)
    Dim i           As Long
    Dim setCol      As Long
    Dim j           As Long
    Dim k           As Long
    Dim duplicate   As Boolean
    Dim temp(1 To 2) As Variant
    Dim sets    As Worksheet
    Dim pairs   As Worksheet
    
    Set sets = ThisWorkbook.Worksheets("Sets")
    Set pairs = ThisWorkbook.Worksheets("Pairs")
       
    setCol = topLeft.Column
    j = topLeft.Row
    i = Int(58 * Rnd) + 1
    sets.Cells(j, setCol).Value = pairs.Cells(i, 1).Value
    sets.Cells(j, setCol + 1).Value = pairs.Cells(i, 2).Value
    
    Do
        i = Int(58 * Rnd) + 1
        
        duplicate = False
        For k = 1 To j
            If pairs.Cells(i, 1) = sets.Cells(k, setCol) _
            Or pairs.Cells(i, 2) = sets.Cells(k, setCol + 1) Then
               duplicate = True
               Exit For
            End If
        Next k
        
        If Not duplicate Then
            j = j + 1
            sets.Cells(j, setCol) = pairs.Cells(i, 1)
            sets.Cells(j, setCol + 1) = pairs.Cells(i, 2)
        End If
        
    Loop Until j = topLeft.Row + 8
    
    For i = topLeft.Row + 7 To topLeft.Row Step -1
        For j = i To topLeft.Row + 7
            With sets
                If .Cells(j, setCol) > .Cells(j + 1, setCol) Then
                    temp(1) = .Cells(j + 1, setCol)
                    .Cells(j + 1, setCol) = .Cells(j, setCol)
                    .Cells(j, setCol) = temp(1)
                    temp(2) = .Cells(j + 1, setCol + 1)
                    .Cells(j + 1, setCol + 1) = .Cells(j, setCol + 1)
                    .Cells(j, setCol + 1) = temp(2)
                End If
            End With
        Next j
    Next i
End Sub

MaxTrax · Apr 22, 2016

Thanks ask2tsp,

Thanks for your answer but…
I didn’t explain properly (my bad). I need each number in each pair to be unique from any other pair. In other words a single number *cannot repeat* anywhere in the *set of 9*

In your result for example the 1^st set C1:D9 contains repeats of “50”, “110”, “80”.

The 2^nd set F1:G9 contains repeats of “250”, “260”.

The pairs can be in any numerical order. Example: 110/140, 40/70, 120/150, 20/30, 320/330, 80/110, 220/250, 140/170 is fine

It would be excellent if the result could be delimitated with a comma and each number in the pair separated by a forward slash as above.

I really do appreciate your effort

LockeGarmin · Apr 23, 2016

I came up with a solution that will require you to make couple of helper CLASS modules. (Please don't create a regular module where noted.

Create a CLASS module and name it "Pair" <----Naming it correctly is important

Code:

Option Explicit

Public Pair1 As String
Public Pair2 As String

Sub SetPair(PairString As String)

  Pair1 = Left$(PairString, InStr(PairString, "/") - 1)
  Pair2 = Mid$(PairString, InStr(PairString, "/") + 1)
  
End Sub

Public Function IsUnique(NewPair As Pair)

Dim Collection As Collection

  On Error GoTo NotUnique

  Set Collection = New Collection
  
  Collection.Add Empty, Me.Pair1
  Collection.Add Empty, Me.Pair2
  Collection.Add Empty, NewPair.Pair1
  Collection.Add Empty, NewPair.Pair2
  
  IsUnique = True

Exit Function

NotUnique:
  Err.Clear
  IsUnique = False

End Function

Create a CLASS module and name it "PairCollection" <----Naming it correctly is important

Code:

Option Explicit

Private Collection As Collection

Private Sub Class_Initialize()
  Set Collection = New Collection
End Sub

Sub Add(NewPair As Pair)

Dim Pair As Pair
  
  For Each Pair In Collection
    If Not Pair.IsUnique(NewPair) Then
      Exit Sub
    End If
  Next Pair
  
  Collection.Add NewPair
  
End Sub

Function Count() As Long
  Count = Collection.Count
End Function

Function ToArray() As Variant()

Dim ReturnArr As Variant
Dim Pair As Pair
Dim x As Long
  
  If Collection.Count = 0 Then
    ToArray = Array()
    Exit Function
  End If
  
  ReDim ReturnArr(0 To Collection.Count - 1)
  
  x = -1
  For Each Pair In Collection
    x = x + 1
    ReturnArr(x) = Pair.Pair1 & "/" & Pair.Pair2
  Next Pair
  
  ToArray = ReturnArr
  
End Function

Create a REGULAR module and put in the following code and name it "SwallowsCarryCoconuts" <----That name isn't important

Code:

Option Explicit

Sub PairsToRange()

Dim Collection As PairCollection
Dim Pair As Pair
Dim PairsArray As Variant
Dim PairString As String
Dim RandomElement As Long

  PairsArray = Array("5/10", "5/20", "5/30", "10/20", _
  "10/40", "20/30", "20/50", "30/60", "40/50", "40/70", _
  "50/60", "50/80", "60/90", "70/80", "70/100", "80/90", _
  "80/110", "90/120", "100/110", "100/130", "110/120", _
  "110/140", "120/150", "130/140", "130/160", "140/150", _
  "140/170", "150/180", "160/170", "160/190", "170/180", _
  "170/200", "180/210", "190/200", "190/220", "200/210", _
  "200/230", "210/240", "220/230", "220/250", "230/240", _
  "230/260", "240/270", "250/260", "250/280", "260/270", _
  "260/290", "270/300", "280/290", "280/310", "290/300", _
  "290/320", "300/330", "310/320", "310/340", "320/330", _
  "320/350", "330/360")

  Set Collection = New PairCollection
  Do Until Collection.Count = 9
    Set Pair = New Pair
    RandomElement = RandBetween(LBound(PairsArray), UBound(PairsArray))
    PairString = PairsArray(RandomElement)
    Call Pair.SetPair(PairString)
    
    Collection.Add Pair
  Loop
  
  [A1] = Join(Collection.ToArray, ", ")
  
End Sub

Function RandBetween(LowerBound As Long, UpperBound As Long) As Long
  Randomize
  RandBetween = Int(Rnd() * (UpperBound - LowerBound + 1)) + LowerBound
End Function

Run [PairsToRange] and it should result in 9 unique pairs in cell A1.

By the way, don't run this looking for more than 15 unique pairs. It gets caught in an infinite loop because it can't find any unique values but it keeps looking forever.

MaxTrax · Apr 23, 2016

Brilliant LockeGarmin -- You guys I don't know

Indeed the "Swallows did Carry the Coconuts". Thank you very much. But now..........

Is there a way to give a *new result* (could be repeats as it's random and that fine) in as many different cells as I like? Could be up to 1,000,000. Say for example A1:A800000 and D3:D50000 or anywhere.

Like you would copy a random formula over multiple cells to get different results. Maybe a UDF. I don't know,

Thanks

MaxTrax · Apr 23, 2016

Also I should have added.....When the sheet/book recalculates new results should appear throughout.

Is that too hard?

Thanks

ask2tsp · Apr 23, 2016

Then this is more like it

Excel Workbook

A

B

C

1

C1

140/170,300/330,80/90,260/270,310/320,200/230,200/230,130/160,20/30

2

C3

3

C5

180/210,230/240,300/330,280/290,5/20,170/200,310/320,130/160,220/250

4

C7

5

C9

160/190,160/190,140/170,110/120,80/90,10/20,70/100,320/350,150/180

6

C11

7

70/100,200/230,170/200,310/340,210/240,160/190,120/150,20/50,260/270

8

9

140/170,250/260,190/220,280/290,5/20,60/90,10/40,100/130,270/300

10

11

10/40,50/80,220/250,140/170,110/120,230/240,310/320,20/30,60/90

Sets

Code:

Option Explicit

Sub setsOf9pairs()
    Dim tl As Range
    Dim sets As Worksheet
    
    Set sets = ThisWorkbook.Worksheets("Sets")
    For Each tl In sets.Range("A1").CurrentRegion
        buildUniqueSet sets.Range(tl.Value)
    Next tl

End Sub

Sub buildUniqueSet(topLeft As Range)
    Dim i           As Long
    Dim setCol      As Long
    Dim j           As Long
    Dim k           As Long
    Dim duplicate   As Boolean
    Dim temp(1 To 2) As Variant
    Dim sets    As Worksheet
    Dim pairs   As Worksheet
    Dim result  As String
    Dim p(9, 2) As Integer
    
    Set sets = ThisWorkbook.Worksheets("Sets")
    Set pairs = ThisWorkbook.Worksheets("Pairs")
       
    setCol = topLeft.Column
    j = 1
    i = Int(58 * Rnd) + 1
    p(1, 1) = pairs.Cells(i, 1).Value
    p(1, 2) = pairs.Cells(i, 2).Value
    Do
        i = Int(58 * Rnd) + 1
        
        duplicate = False
        For k = 0 To j - 1
            If pairs.Cells(i, 1) = p(k, 1) _
            Or pairs.Cells(i, 1) = p(k, 2) _
            Or pairs.Cells(i, 2) = p(k, 1) _
            Or pairs.Cells(i, 2) = p(k, 2) Then
               duplicate = True
               Exit For
            End If
        Next k
        
        If Not duplicate Then
            j = j + 1
            p(j, 1) = pairs.Cells(i, 1)
            p(j, 2) = pairs.Cells(i, 2)
        End If
        DoEvents
    Loop Until j = 9
    result = ""
    For i = 1 To 8
        result = result & p(i, 1) & "/" & p(i, 2) & ","
    Next i
    result = result & p(9, 1) & "/" & p(9, 2)
    topLeft = result
End Sub

LockeGarmin · Apr 23, 2016

Here's the modifications for a UDF though it will probably be pretty slow if you are doing a million of these. Adding 'Application.Volatile' will make them refresh every time the workbook calculates though I doubt that is what you'll want when you see how slow it is.

Code:

[COLOR=#333333]Function PairsToRange() As String
[/COLOR]
Dim Collection As PairCollection
Dim Pair As Pair
Dim PairsArray As Variant
Dim PairString As String
Dim RandomElement As Long

  Application.Volatile

  PairsArray = Array("5/10", "5/20", "5/30", "10/20", _
  "10/40", "20/30", "20/50", "30/60", "40/50", "40/70", _
  "50/60", "50/80", "60/90", "70/80", "70/100", "80/90", _
  "80/110", "90/120", "100/110", "100/130", "110/120", _
  "110/140", "120/150", "130/140", "130/160", "140/150", _
  "140/170", "150/180", "160/170", "160/190", "170/180", _
  "170/200", "180/210", "190/200", "190/220", "200/210", _
  "200/230", "210/240", "220/230", "220/250", "230/240", _
  "230/260", "240/270", "250/260", "250/280", "260/270", _
  "260/290", "270/300", "280/290", "280/310", "290/300", _
  "290/320", "300/330", "310/320", "310/340", "320/330", _
  "320/350", "330/360")

  Set Collection = New PairCollection
  Do Until Collection.Count = 9
    Set Pair = New Pair
    RandomElement = RandBetween(LBound(PairsArray), UBound(PairsArray))
    PairString = PairsArray(RandomElement)
    Call Pair.SetPair(PairString)
    
    Collection.Add Pair
  Loop
  
  [FONT=Verdana]PairsToRange[/FONT] = Join(Collection.ToArray, ", ")

[COLOR=#333333]End [/COLOR][COLOR=#333333]Function[/COLOR]

And really, UDFs are pretty slow. You can just try using this UDF 1m times and you'll see that something so simple will take quite a while.

Code:

Function One() As Long
One = 1
End Function

MaxTrax · Apr 23, 2016

Hi ask2tsp,

Thanks for your time and effort.... but there are repeating numbers in a single "set of 9" and repeating pairs in a single "set of 9".
*Single numbers* can't repeat in a "set of 9" AND *pairs* can't repeat in a "set of 9". Below from your build.

C1		210/240,130/140,130/140,230/260,100/110,60/90,50/60,190/200,10/40 < repeating pair
C2		140/170,300/330,80/90,260/270,310/320,200/230,200/230,130/160,20/30 < repeating pair
C3		180/210,230/240,300/330,280/290,5/20,170/200,310/320,130/160,220/250 < Ok
C4		160/190,160/190,140/170,110/120,80/90,10/20,70/100,320/350,150/180
C5		70/100,200/230,170/200,310/340,210/240,160/190,120/150,20/50,260/270 < repeat number<repeating number<="" td=""></repeating>

Also, and this may not be possible other than from another approach but is very important, once the correct "set of 9" results are obtained they then definitely need to be recalculated with the rest of the sheet when required. There will be a large number of formulas using these "set of 9" results therefore they (set of 9) are only relevant for one sheet calculation. I then require a recalculation.

Also is it possible to adjust the code so that in sheet "Sets" I can nominate a range or better still ranges rather than single cells C1, C3, C8.
I note, as the code is now, if I give the range D1:D300 in A1 the result is the same over the whole range of D1:D300

Thanks

Peter_SSs · Apr 24, 2016

I'm a bit late to the party, but I would also be very wary about making this volatile & using it in a large range.
Anyway, here is my direct udf to test should you wish to try alternatives.

Rich (BB code):

Function Pairs(howmany As Long) As String
  Static origprs As Variant
  
  Dim remprs As Variant, num As Variant, thesenums As Variant
  Dim s As String, tmp As String
  Dim i As Long
  
  Application.Volatile
  Randomize
  If IsEmpty(origprs) Then origprs = Split("/5/10/ /5/20/ /5/30/ /10/20/ /10/40/ /20/30/ /20/50/ /30/60/ /40/50/ /40/70/ /50/60/" _
                                    & " /50/80/ /60/90/ /70/80/ /70/100/ /80/90/ /80/110/ /90/120/ /100/110/ /100/130/ /110/120/" _
                                    & " /110/140/ /120/150/ /130/140/ /130/160/ /140/150/ /140/170/ /150/180/ /160/170/ /160/190/" _
                                    & " /170/180/ /170/200/ /180/210/ /190/200/ /190/220/ /200/210/ /200/230/ /210/240/ /220/230/" _
                                    & " /220/250/ /230/240/ /230/260/ /240/270/ /250/260/ /250/280/ /260/270/ /260/290/ /270/300/" _
                                    & " /280/290/ /280/310/ /290/300/ /290/320/ /300/330/ /310/320/ /310/340/ /320/330/ /320/350/ /330/360/")
  remprs = origprs
  For i = 1 To howmany
    If UBound(remprs) = -1 Then
      Pairs = "Error"
      Exit Function
    End If
    s = remprs(Int(Rnd() * (UBound(remprs) + 1)))
    s = Mid(s, 2, Len(s) - 2)
    tmp = tmp & ", " & s
    thesenums = Split(s, "/")
    For Each num In thesenums
      remprs = Filter(remprs, "/" & num & "/", False)
    Next num
  Next i
  Pairs = Mid(tmp, 3)
End Function

Excel Workbook

B

1

5/20, 80/110, 320/350, 190/220, 140/150, 290/300, 260/270, 250/280, 90/120

2

260/270, 70/80, 300/330, 40/50, 120/150, 250/280, 210/240, 310/320, 20/30

3

120/150, 170/180, 250/280, 220/230, 50/60, 300/330, 260/270, 290/320, 10/40

4

310/320, 200/230, 210/240, 110/140, 190/220, 300/330, 20/30, 100/130, 170/180

5

30/60, 210/240, 130/140, 20/50, 290/300, 110/120, 170/200, 320/350, 190/220

6

50/60, 170/180, 130/160, 110/120, 300/330, 310/320, 190/220, 230/260, 240/270

7

200/230, 60/90, 310/320, 80/110, 10/20, 130/160, 260/290, 40/70, 250/280

8

140/170, 70/100, 190/200, 10/40, 5/30, 220/250, 240/270, 150/180, 130/160

9

20/50, 40/70, 280/290, 5/10, 80/110, 270/300, 230/240, 310/320, 170/180

10

120/150, 320/350, 290/300, 220/250, 40/70, 50/80, 240/270, 5/20, 160/190

Sheet2

Give random unique set of 9 pairs

MaxTrax

Board Regular

Excel Facts

ask2tsp

Well-known Member

MaxTrax

Board Regular

LockeGarmin

Active Member

MaxTrax

Board Regular

MaxTrax

Board Regular

ask2tsp

Well-known Member

LockeGarmin

Active Member

MaxTrax

Board Regular

Peter_SSs

MrExcel MVP, Moderator

Similar threads

Forum statistics

Share this page

	A	B	C	D	E	F	G	H	I	J
1	C1		40	50		10	20		5	30
2	F1		50	80		40	70		20	50
3	I1		60	90		50	80		50	60
4	C11		80	110		120	150		60	90
5	F11		90	120		200	210		130	140
6	I11		110	140		220	250		140	170
7			170	180		250	260		170	180
8			190	200		260	270		180	210
9			290	300		320	330		230	260
10
11			5	10		20	50		10	20
12			20	30		30	60		40	70
13			140	150		80	110		80	110
14			200	230		110	120		120	150
15			230	240		130	160		160	190
16			250	260		160	170		220	230
17			260	290		170	200		260	270
18			300	330		210	240		300	330
19			330	360		310	340		320	350

	A	B	C	D	E	F	G	H	I	J
1	C1		40	50		10	20		5	30
2	F1		50	80		40	70		20	50
3	I1		60	90		50	80		50	60
4	C11		80	110		120	150		60	90
5	F11		90	120		200	210		130	140
6	I11		110	140		220	250		140	170
7			170	180		250	260		170	180
8			190	200		260	270		180	210
9			290	300		320	330		230	260
10
11			5	10		20	50		10	20
12			20	30		30	60		40	70
13			140	150		80	110		80	110
14			200	230		110	120		120	150
15			230	240		130	160		160	190
16			250	260		160	170		220	230
17			260	290		170	200		260	270
18			300	330		210	240		300	330
19			330	360		310	340		320	350

Give random unique set of 9 pairs

Board Regular

Excel Facts

Well-known Member

Board Regular

Active Member

Board Regular

Board Regular

Well-known Member

Active Member

Board Regular

MrExcel MVP, Moderator

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock

	A	B	C	D	E	F	G	H	I	J
1	C1		40	50		10	20		5	30
2	F1		50	80		40	70		20	50
3	I1		60	90		50	80		50	60
4	C11		80	110		120	150		60	90
5	F11		90	120		200	210		130	140
6	I11		110	140		220	250		140	170
7			170	180		250	260		170	180
8			190	200		260	270		180	210
9			290	300		320	330		230	260
10
11			5	10		20	50		10	20
12			20	30		30	60		40	70
13			140	150		80	110		80	110
14			200	230		110	120		120	150
15			230	240		130	160		160	190
16			250	260		160	170		220	230
17			260	290		170	200		260	270
18			300	330		210	240		300	330
19			330	360		310	340		320	350