Permutation in Excel

[ygilbert]

I have the following:

(A,B,C,D) and (1,2,3) and (X,Y,Z)

So I would like to get the following combinations

A1X,A1Y,A1Z, A2X,A2Y,A2Z, ..., D3X,D3Y,D3Z

How is this done in excel?

 

[MaxTrax]

Hi pgc01, JackBean and Others

I posted this yesterday but had no replies so thought I might try here as it seems similar to what I’m requesting (hopefully).

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

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)

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

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.

Below are the 58 pairs.

Thanks for any help as my VBA knowledge is very limited.

MaxTrax

	A	B	C	D	E	F
1	5	10
2	5	20
3	5	30
4	10	20
5	10	40
6	20	30
7	20	50
8	30	60
9	40	50
10	40	70
11	50	60
12	50	80
13	60	90
14	70	80
15	70	100
16	80	90
17	80	110
18	90	120
19	100	110
20	100	130
21	110	120
22	110	140
23	120	150
24	130	140
25	130	160
26	140	150
27	140	170
28	150	180
29	160	170
30	160	190
31	170	180
32	170	200
33	180	210
34	190	200
35	190	220
36	200	210
37	200	230
38	210	240
39	220	230
40	220	250
41	230	240
42	230	260
43	240	270
44	250	260
45	250	280
46	260	270
47	260	290
48	270	300
49	280	290
50	280	310
51	290	300
52	290	320
53	300	330
54	310	320
55	310	340
56	320	340
57	320	330
58	330	360
59
60
62

<tbody>
</tbody>

 

[MaxTrax]

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

I should have also added if the result for each *set of 9* could be in text format in a single cell. Example:

|A |B |C
1 |210/240, 130/140, 90/120, 40/70, 160/190, 5/10, 50/80, 100/110 | Etc |
2 |10/40, 100/130, 5/30, 310/340, 200/230, 70/80, 160/170, 250/280 | |
3 |Etc
4 |

Also I didn't explain in previous post.
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*
This would be incorrect: 220/250, 250/260, 300/330, 20/50, 40/70, 110/120, 50/80, 250/280, 290/300

Thanks

 

[MaxTrax]

Let me clean that up a bit

	A	B	C	D
1	210/240, 130/140, 90/120, 40/70, 160/190, 5/10, 50/80, 100/110	Etc
2	10/40, 100/130, 5/30, 310/340, 200/230, 70/80, 160/170, 250/280
3	Etc
4

<tbody>
</tbody>

 

[Cindy Ellis]

Hi MaxTrax,
Are the available pairs always in columns A & B (one number in each cell)?
Will there always be 58 pairs?
I understand the restrictions on uniqueness...but still thinking about the best approach.

 

[MaxTrax]

Are the available pairs always in columns A & B (one number in each cell)?
Will there always be 58 pairs?

Hi Cindy,

Yes they can be always in A&B but could be anywhere. For example in another sheet.

There will always be 58 pairs.

Thanks

 

[Cindy Ellis]

OK...this seems to work. It's probably over-engineered, but that's what happens when I'm too tired to simplify it
It puts the output into column D. As written, it assumes that there will be a header row on the columns.
Each time you run it, it will add the output in the next row in column D.
Please give this a try and let me know if it worked.

Option Explicit

Sub UniqueItemPairs()


' selects 9 pairs randomly from the range A2:B59,
' testing each as it is selected to ensure that neither member of the pair is re-used


Dim TotalPairs As Integer  'this can be changed if there are ever more or fewer pairs
Dim UniquePairs As Integer '
Dim PairCount As Integer
Dim PairCheck As Variant ' this will be the dictionary object to ensure there aren't any duplicated entries
Dim MyPairs As String ' this will hold the output pairs
Dim Checked As Integer
Dim RowNum As Long, NextRow As Long
Dim P1 As String, P2 As String


Set PairCheck = CreateObject("scripting.dictionary") 'this is how we check for uniqueness
TotalPairs = 58 'we use this to establish the range, and to ensure that the macro doesn't go on forever
UniquePairs = 9
PairCount = 1
NextRow = ActiveSheet.Cells(Rows.count, 4).End(xlUp).Row + 1 'column D will hold the output

Randomize
While PairCount <= UniquePairs And Checked < TotalPairs
    RowNum = Int(Rnd() * TotalPairs) + 2  'change this to 1 if there's no header row
'    MsgBox RowNum  'uncomment for troubleshooting
    With ActiveSheet
        P1 = .Range("A" & RowNum).Value
        P2 = .Range("B" & RowNum).Value
    End With
    'Now test each member of the pair against the dictionary
    If Not PairCheck.Exists(P1) And Not PairCheck.Exists(P2) Then
    'first add each item of the pair to the "used" list
        PairCheck.Add P1, P1
        PairCheck.Add P2, P2
    'now add the items as a pair to the output string
        MyPairs = MyPairs & P1 & "/" & P2
        If PairCount < UniquePairs Then MyPairs = MyPairs & ", "
        PairCount = PairCount + 1
    End If
    'whether or not we found a pair with unique values, increase Checked by 1 so we don't go on forever
    Checked = Checked + 1
Wend
' Get rid of the final comma and space
ActiveSheet.Range("D" & NextRow).Value = MyPairs


End Sub

 

[MaxTrax]

Great work Cindy..... Truly

Some more questions though and I apologize for being a bit all over the place with this.

Is there a way to run the macro over multiple cells automatically? That is any range/ranges of cells I choose.

Example over D1:D36000 *and* F1:F36000 *and* H1:H98000 or anywhere. Then when sheet/book is recalculated the random results will change. Maybe I need a UDF which can be copied to wherever. Not sure.

This one is slightly off topic but is important to me.

Can you create a macro which will list ALL the unique (no numbers repeating in a set) sets of *9 pairs* ?

I know the list will be HUGE but no where near as large as where numbers do repeat in a set.

 

[Cindy Ellis]

Hi MaxTrax,
Here's a modified version that allows you to output up to 100 columns of up to 100000 rows, starting at a column of your choice. It doesn't have any error checking to speak of, so if you start in the last possible column of the worksheet, or if you're using an older version of Excel that only has 65535 rows, it will flake out.
I'm assuming that you will be the one selecting how many rows, columns, and where you want them, so answer the prompts with those limitations in mind
It takes quite a while to run...when I chose 36000 rows in each of 3 columns, it was well over a minute on a reasonably fast system.
In response to the "all unique sets of 9 pairs", since there isn't any control on how many individual members of pairs are found more than once in the overall set, we have to assume (worst case) that none are replicated. In that case, there are over 10 billion (10^10) possible combinations. If replicates reduce that 100-fold, there are still 100 million!! As updated below, the macro will allow you to generate 10 million sets of pairs (note that this will require a several hours to complete), but it is unlikely that all sets of 9 are unique within that "population".

Sub UniqueItemPairs()

' For a user-entered number of rows, columns, and starting position:
' selects 9 pairs randomly from the range A2:B59,
' tests each as it is selected to ensure that neither member of the pair is re-used
' outputs the set of 9 pairs to the next row of a user-selected range


Dim TotalPairs As Integer  'this can be changed below if there are ever more or fewer pairs
Dim UniquePairs As Integer 'this can be changed below if you want more or fewer pairs in the output
Dim PairCount As Integer 'counter to keep track of how many have been collected so far
Dim PairCheck As Variant ' this will be the dictionary object to ensure there aren't any duplicated entries
Dim MyPairs As String ' this will hold the output pairs
Dim Checked As Integer
Dim RowNum As Long, NextRow As Long
Dim P1 As String, P2 As String
Dim HowManyRows As Long, OutputRow As Long
Dim HowManyCols As Long, StartingCol As Long, OutputCol As Long, LastCol As Long




Set PairCheck = CreateObject("scripting.dictionary")
TotalPairs = 58 'we use this to establish the range to search for pairs, and to ensure that the macro doesn't go on forever
UniquePairs = 9
PairCount = 1


HowManyRows = InputBox("How many rows of output do you want?")
If Not HowManyRows > 0 And Not HowManyRows <= 100000 Then
    MsgBox "Only enter numbers between 1 and 100000"
    Exit Sub
End If
HowManyCols = InputBox("How many columns of output do you want?")
If Not HowManyCols > 0 And Not HowManyCols <= 100 Then
    MsgBox "Only enter numbers between 1 and 100"
    Exit Sub
End If


StartingCol = InputBox("What column should the output start in?  Enter a number between 4 and 100")
If Not StartingCol >= 4 And Not StartingCol <= 100 Then
    MsgBox "Only enter numbers between 4 and 100"
    Exit Sub
End If


LastCol = StartingCol + ((HowManyCols - 1) * 2)


Randomize
For OutputCol = StartingCol To LastCol Step 2
    For OutputRow = 2 To HowManyRows + 1 'allows for header row
        'Start with an empty string, and internal counters reset to 1, and empty dictionary object
        PairCheck.RemoveAll
        PairCount = 1
        Checked = 1
        MyPairs = ""
        While PairCount <= UniquePairs And Checked < TotalPairs
            RowNum = Int(Rnd() * TotalPairs) + 2  'change this to 1 if there's no header row
        '    MsgBox RowNum  'uncomment for troubleshooting
            With ActiveSheet
                P1 = .Range("A" & RowNum).Value
                P2 = .Range("B" & RowNum).Value
            End With
            'Now test each member of the pair against the dictionary
            If Not PairCheck.Exists(P1) And Not PairCheck.Exists(P2) Then
            'first add each item of the pair to the "used" list
                PairCheck.Add P1, P1
                PairCheck.Add P2, P2
            'now add the items as a pair to the output string
                MyPairs = MyPairs & P1 & "/" & P2
                If PairCount < UniquePairs Then MyPairs = MyPairs & ", "
                PairCount = PairCount + 1
            End If
            'whether or not we found a pair with unique values, increase Checked by 1 so we don't go on forever
            Checked = Checked + 1
        ActiveSheet.Cells(OutputRow, OutputCol).Value = MyPairs
        Wend
    Next OutputRow
Next OutputCol
    
End Sub

 

[MaxTrax]

Hello Cindy,

Thank you. That is exactly what I require and is quite outstanding.

But (there's always a but)......

After the macro has run to my area/s of specification and the results are in place, then when the sheet/book is recalculated, can the macro results *also* be recalculated to give new results (new sets of 9)?

It doesn't matter if some *sets of 9* repeat which is quite possible but rare. When finally constructed the sheet/book will have many different formulas using ALL the different *sets of 9* cells but only once so the *sets of 9* need to recalculate with the rest of the sheet/book.

If this is too hard I'm open to suggestions of how to achieve above.

but it is unlikely that all sets of 9 are unique within that "population"

This is fine.

Thank you again for your work.

 

[Cindy Ellis]

These sets are assembled with a macro, not formulas. If you re-run the macro, it will generate new sets of pairs that will overwrite the ones that were there when you started, but you will need to re-enter the # columns, rows, etc.
You could put a button on the sheet to simplify the process, or you could kick it off based on a worksheet event of your choosing.
If you were to somehow figure a formula approach, you would want to turn off automatic calculation.