Excel alphabet permutations with limitations

[saumyar]

Hi All,

I am new user and I have some similar requirement. I need permutation of A, B, C and D but I also need to specify maximum how many times each letter can occur.
i.e I need A to appear max 4 times, B 2 times, C 2 time and D 2 times. Valid examples AAAA, AAAB, AABB, AACC, CCDD (since these are within limits). Invalid examples ABBB, ACCC, ADDD, CCC, CCCA (because B,C,D appeared more than 2 time)
Is there an easy way to do this? Any help/direction would be appreciated.

 

[shg]

This list?

AAAA
BAAA
BAAA
BAAA
BAAA
BAAA
BAAA
BAAA
BAAA
BBAA
BBAA
BBAA
BBAA
BBAA
BBAA
CAAA
CAAA
CAAA
CAAA
CBAA
CBAA
CBAA
CBAA
CBAA
CBAA
CBAA
CBAA
CBAA
CBAA
CBAA
CBAA
CBBA
CBBA
CBBA
CBBA
CAAA
CAAA
CAAA
CAAA
CBAA
CBAA
CBAA
CBAA
CBAA
CBAA
CBAA
CBAA
CBAA
CBAA
CBAA
CBAA
CBBA
CBBA
CBBA
CBBA
CCAA
CCAA
CCAA
CCAA
CCAA
CCAA
CCBA
CCBA
CCBA
CCBA
CCBA
CCBA
CCBA
CCBA
CCBB
DAAA
DAAA
DAAA
DAAA
DBAA
DBAA
DBAA
DBAA
DBAA
DBAA
DBAA
DBAA
DBAA
DBAA
DBAA
DBAA
DBBA
DBBA
DBBA
DBBA
DCAA
DCAA
DCAA
DCAA
DCAA
DCAA
DCBA
DCBA
DCBA
DCBA
DCBA
DCBA
DCBA
DCBA
DCBB
DCAA
DCAA
DCAA
DCAA
DCAA
DCAA
DCBA
DCBA
DCBA
DCBA
DCBA
DCBA
DCBA
DCBA
DCBB
DCCA
DCCA
DCCA
DCCA
DCCB
DCCB
DAAA
DAAA
DAAA
DAAA
DBAA
DBAA
DBAA
DBAA
DBAA
DBAA
DBAA
DBAA
DBAA
DBAA
DBAA
DBAA
DBBA
DBBA
DBBA
DBBA
DCAA
DCAA
DCAA
DCAA
DCAA
DCAA
DCBA
DCBA
DCBA
DCBA
DCBA
DCBA
DCBA
DCBA
DCBB
DCAA
DCAA
DCAA
DCAA
DCAA
DCAA
DCBA
DCBA
DCBA
DCBA
DCBA
DCBA
DCBA
DCBA
DCBB
DCCA
DCCA
DCCA
DCCA
DCCB
DCCB
DDAA
DDAA
DDAA
DDAA
DDAA
DDAA
DDBA
DDBA
DDBA
DDBA
DDBA
DDBA
DDBA
DDBA
DDBB
DDCA
DDCA
DDCA
DDCA
DDCB
DDCB
DDCA
DDCA
DDCA
DDCA
DDCB
DDCB
DDCC

 

[saumyar]

kind of.. aren't you missing combinations which start with A? (i.e AAAB, AAAC, AAAD, AABA, AABB, and so on..)..
i also need combination with 2 alphabets and 3 alphabets (i.e AA, AB,AC, CA,CB,CC, AAA, ABB, ABC, etc) but i have already achieved it.. since it is easier than this..

 

[Eric W]

If you start with a worksheet like this:

	A	B	C
A
B
C
D	2

<colgroup><col style="width: 25pxpx"><col><col><col></colgroup><thead>
</thead><tbody>
[TD="align: center"]1[/TD]

[TD="align: right"]4[/TD]
[TD="align: right"]4[/TD]

[TD="align: center"]2[/TD]

[TD="align: right"]2[/TD]
[TD="align: right"][/TD]

[TD="align: center"]3[/TD]

[TD="align: right"]2[/TD]
[TD="align: right"][/TD]

[TD="align: center"]4[/TD]

[TD="align: right"][/TD]

</tbody>

Sheet1​

where your alphabet is in column A, the maximum number of times each letter is allowed in B, and the word length is in C1, then this macro will place all the results in column E.

Sub Permute1()
Dim MyData As Variant, ix() As Long, i As Long, wordlen As Long, str1 As String
Dim ctrs(1 To 10) As Long, wk As Variant, MyDict As Object


    MyData = Range("A1:B" & Cells(Rows.Count, "A").End(xlUp).Row).Value
    wordlen = Range("C1").Value
    ReDim ix(1 To wordlen)
        
    For i = 1 To wordlen
        ix(i) = 1
    Next i
    Set MyDict = CreateObject("Scripting.Dictionary")
    
NextOne:
    str1 = ""
    Erase ctrs
    For i = 1 To wordlen
        str1 = str1 & MyData(ix(i), 1)
        ctrs(ix(i)) = ctrs(ix(i)) + 1
    Next i
    For i = 1 To UBound(MyData)
        If ctrs(i) > MyData(i, 2) Then GoTo Incr:
    Next i
    MyDict.Add str1, 1
    
Incr:
    For i = wordlen To 1 Step -1
        ix(i) = ix(i) + 1
        If ix(i) <= UBound(MyData) Then GoTo NextOne:
        ix(i) = 1
    Next i
    
    Range("E:E").ClearContents
    If MyDict.Count < 32767 Then
        Range("E1").Resize(MyDict.Count) = WorksheetFunction.Transpose(MyDict.keys)
    Else
        Application.ScreenUpdating = False
        wk = MyDict.keys
        For i = 0 To UBound(wk)
            Cells(i + 1, "E") = wk(i)
        Next i
        Application.ScreenUpdating = True
    End If
    
End Sub

 

[pgc01]

Hi

With the same setup as Eric's, another option

Sub Comb()
Dim vArr As Variant
Dim lRow As Long

vArr = Range("A1", Range("B1").End(xlDown)).Value
Comb1 "", vArr, Range("C1").Value, 1, lRow

End Sub

Sub Comb1(ByVal sComb As String, ByVal vArr As Variant, ByVal p As Long, ByVal lPos As Long, lRow As Long)
Dim j As Long

For j = 1 To UBound(vArr)
    If vArr(j, 2) > 0 Then
        If lPos < p Then
            vArr(j, 2) = vArr(j, 2) - 1
            Comb1 sComb & vArr(j, 1), vArr, p, lPos + 1, lRow
            vArr(j, 2) = vArr(j, 2) + 1
        Else
            lRow = lRow + 1
            Range("E" & lRow).Value = sComb & vArr(j, 1)
        End If
    End If
Next j
       
End Sub