Limited Repeating Permutation Macro

[dlybb]

I have found some threads that are close to this question, but none that I have been able to modify for my needs. The question is this:

Say I have 3 object types a,b and c, where each has a quantity of x,y and z respectively.

I need to load all of the possible permutations into a matrix (not cells). In this case, I require permutations (as opposed to combinations).

I have never dealt with this type of code before (as in statistics).

 

[shg]

For example, ...?

 

[dlybb]

For example, ...?

Here's an example:

Object A- Qty 2
Object B- Qty 1
Object C- Qty 1

Permutations:
AABC
AACB
ABAC
ABCA
ACBA
ACAB

I think that's it.

So basically, I would have a 2x4 matrix as follows
A,2
B,1
C,1

and from that, I want to load another matrix approximately as follows:
A,A,B,C,
A,A,C,B,
A,B,A,C,
A,B,C,A,
A,C,B,A,
A,C,A,B,

Please note, I may have missed a permutation (hence why I am trying to make this macro).

 

[shg]

Row\Col	A​	B​	C​	D​
1​	AABC	A1:A24: {=StrPermute("AABC")}		AABC
2​	AACB			AACB
3​	ABAC			ABAC
4​	ABCA			ABCA
5​	ACAB			ACAB
6​	ACBA			ACBA
7​	AABC			BAAC
8​	AACB			BACA
9​	ABAC			BCAA
10​	ABCA			CAAB
11​	ACAB			CABA
12​	ACBA			CBAA
13​	BAAC
14​	BACA
15​	BAAC
16​	BACA
17​	BCAA
18​	BCAA
19​	CAAB
20​	CABA
21​	CAAB
22​	CABA
23​	CBAA
24​	CBAA

That's an array formula in A1:A24. Then copy and paste values in another column, then remove duplicates.

Function StrPermute(sInp As String) As Variant
    Dim asOut() As String
    
    If Len(sInp) > 9 Then
        StrPermute = "Too long!"
    Else
        ReDim asOut(1 To WorksheetFunction.Fact(Len(sInp)), 1 To 1)
        GetPermutation "", sInp, asOut, 0
        StrPermute = asOut
    End If
End Function

Sub GetPermutation(sL As String, sR As String, asOut() As String, nOut As Long)
    ' adapted from http://spreadsheetpage.com/index.php/site/tip/generating_permutations/
    ' source of algorithm unknown
    
    Dim i As Integer
    Dim j As Integer
    
    j = Len(sR)
    If j <= 1 Then
        nOut = nOut + 1
        asOut(nOut, 1) = sL & sR
    Else
        For i = 1 To j
            GetPermutation sL & Mid(sR, i, 1), Left(sR, i - 1) & Right(sR, j - i), asOut, nOut
        Next
    End If
End Sub

 

[dlybb]

Thanks for your reply. I will not be able to manually remove duplicates, because I will be working with somewhere around 1200 permutations about 50 times per macro run, and that is just a lot of work. Also, the permutations cannot be output to cells, but held in a matrix (or multidimensional array) in the code only. One permutation will be selected, and only that one will be output.

I know I could just use a full permutation set and ignore the repeated objects, but if I do, the computational requirements will grow significantly.

I am a bit of a beginner in VBA (and coding in general), but I need to do this entirely in the macro, no cells. I have the input array made, I just don't know how to load all of the relevant permutations into a new array.

 

[dlybb]

Just to be more clear, here is what I have so far:

A	B	C
Length	Qty	Item#
5	2	1
6	6	2
9	4	3

<tbody>
</tbody>

Sub Cutlist()

'Find number of items and total parts, and load them into an array
i = 2
specitem = 0
partnum = 0

While Cells(i, 1) <> ""

    specitem = specitem + 1
    partnum = partnum + Cells(i, 2)
    i = i + 1
    
Wend

'Find number of possible permutations
'sum(total qty factorial)/(item n qty factorial*itemn+1 wty factorial...)
'Find the numerator
i = 1
numerator = 1
newnumerator = 0
While i <= partnum

    numerator = numerator * (newnumerator + 1)
    i = i + 1
    newnumerator = newnumerator + 1
    
Wend

'Find the denomenator

i = 1
denomenator = 1
denomenatori = 1
newdenomenatori = 0
While i <= specitem
    qtyi = Cells(i + 1, 2)
    While qtyi > 0
    
        denomenatori = denomenatori * (newdenomenatori + 1)
        newdenomenatori = 1 + newdenomenatori
        qtyi = qtyi - 1
        
    Wend
    
    denomenator = denomenator * denomenatori
    newdenomenatori = 0
    denomenatori = 1
    i = i + 1
Wend

'Total number of permutations
permnum = newnumerator / denomenator

'Define a multidimensional array, with each permutation of the total number system
'Array is dimensionally: permnum X partnum

'This is where I fall apart!
'No idea how to go about this in an efficient way!

End Sub

 

[shg]

Counting the number of distinct permutations is easy; generating them is messy.

 

[shg]

Just to be more clear, here is what I have so far:

A	B	C
Length	Qty	Item#
5	2	1
6	6	2
9	4	3

<tbody>
</tbody>

That example is equivalent to funding the distinct permutations of AABBBBBBCCCC, of which there are 13,860. There are two ways to do that.

One would be a minor adaptation of the prior code to check for repeats before adding a given permutation. Unfortunately, that requires evaluating all 12! (479,001,600) possibilities, which would be dog slow.

The second would be to count the repetitions of each symbol (i.e., 2,6,4). Then generate all combinations of 12 choose 2, all combinations of the remaining 10 choose 6, and then the single combination of the remaining 4 choose 4. That would be much faster, but a much more complicated piece of code for the general case.

 

[dlybb]

Wow. Thanks so much for your input! This is a bit to take in.
So if we go with option 2, would you be able to show me an example of even a non-generic piece of code. I am struggling with this concept. Do I have to write a code to find all of the permutations manually? I suppose it can be done, but I can see that it will get really complicated really quickly.

 

[shg]

Row\Col	A​	B​	C​	D​	E​	F​	G​
1​	AABBBBBBCCCC		Symbol​	String​	Count​	Permutations​
2​	AABBBBBCBCCC			AABBBBBBCCCC	12​	479,001,600​	F2: =FACT(E2)
3​	AABBBBCBBCCC		A	BBBBBBCCCC	2​
4​	AABBBCBBBCCC		B	CCCC	6​
5​	AABBCBBBBCCC		C		4​
6​	AABCBBBBBCCC				0​
7​	AACBBBBBBCCC				0​
8​	AABBBBBCCBCC				0​
9​	AABBBBCBCBCC				0​
10​	AABBBCBBCBCC				0​
11​	AABBCBBBCBCC				0​
12​	AABCBBBBCBCC				0​	13,860​	F12: {=F2/PRODUCT(FACT(E3:E12))}
13​	AACBBBBBCBCC
14​	AABBBBCCBBCC
15​	AABBBCBCBBCC
16​	AABBCBBCBBCC

See the workbook at https://app.box.com/s/3hfnp70rdcfm78tsgvzzup7307wyt6l0.