create a permutation list

[valuechained]

Hi guys,

I hope you can help me with a particularly tricky problem that I encountered this morning.

I have several items that I would like to combine, lets call them characters A, B, C, D, E

Each character is situated in a different column, next to each other. Below, I would like to create a list of all possible combinations of these characters. The sequence is not important and each row should contain a unique combination of characters.

I have counted 31 combinations for the ABCDE set, namely

1 for ABCDE
5 for A, B, C, D, E each
5 for choosing 5 unique sets of four from a set of five (5!/(4!*(5-4)!)
10 for choosing 10 unique sets of three from a set of five (5!/(3!*(5-3)!)
10 for choosing 10 unique sets of two from a set of five (5!/(2!*(5-2)!)

To complicate matters, I have several other character strings where I would like a list of combinations. For example A, B, C, D, E, F, G, H 9 (a longer set).

By the way, each combination should be spread accross several columns (e.g. one colum per character, see the question marks in the table below)

Any advice would be very much appreciated. This makes my head spin since a couple of hours.

question.xls
	A	B	C	D	E	F
3	Category	A	B	C	D	E
4	Permutation1	?	?	?	?	?
5	Permutation2	?	?	?	?	?
6	Permutation3	?	?	?	?	?
7	Permutation4	?	?	?	?	?
8	Permutation5	?	?	?	?	?
9	Permutation6	?	?	?	?	?
10	Permutation7	?	?	?	?	?
11	Permutation8	?	?	?	?	?
12	Permutation9	?	?	?	?	?
13	Permutation10	?	?	?	?	?
14	Permutation11	?	?	?	?	?
15	Permutation12	?	?	?	?	?
16	Permutation13	?	?	?	?	?
17	Permutation14	?	?	?	?	?
18	Permutation15	?	?	?	?	?
19	Permutation16	?	?	?	?	?
20	Permutation17	?	?	?	?	?
21	Permutation18	?	?	?	?	?
22	Permutation19	?	?	?	?	?
23	Permutation20	?	?	?	?	?
24	Permutation21	?	?	?	?	?
25	Permutation22	?	?	?	?	?
26	Permutation23	?	?	?	?	?
27	Permutation24	?	?	?	?	?
28	Permutation25	?	?	?	?	?
29	Permutation26	?	?	?	?	?
30	Permutation27	?	?	?	?	?
31	Permutation28	?	?	?	?	?
32	Permutation29	?	?	?	?	?
Sheet1

 

[verluc]

Try,

Dim CurrentRow

Sub GetString()
Dim InString As String
InString = InputBox("Enter text to permute:")
If Len(InString) < 2 Then Exit Sub
If Len(InString) >= 8 Then
MsgBox "Too many permutations!"
Exit Sub
Else
ActiveSheet.Columns(1).Clear
CurrentRow = 1
Call GetPermutation("", InString)
End If
End Sub

Sub GetPermutation(x As String, y As String)
Dim i As Integer, j As Integer
j = Len
If j < 2 Then
Cells(CurrentRow, 1) = x & y
CurrentRow = CurrentRow + 1
Else
For i = 1 To j
Call GetPermutation(x + Mid(y, i, 1), _
Left(y, i - 1) + Right(y, j - i))
Next
End If
End Sub

 

[valuechained]

Hi verluc

thanks a lot for this. It works very well if I only wanted permutations. I think I expressed it incorrectly. I would like the unique character combinations that are possible with a text string.

Therefore, although your tools gives me all permutations of ABCDE, I would only count this as one, because DECBA, for example, contains the same characters.

However, I would like to have the unique combinations of all possible subsets of ABCDE.

One possible subset could be "A"

Another possible subset could be "AD"

Another possible subset could be "ABCE" (and once I have listed ABCE I would not list ACBE, since it contains the same characters)

In addition the first subset of ABCDE is ABCDE itself. According to my calculation, there should be 31 unique subsets (see previous post).

Hope this makes sense and hope you can help!

Thanks a lot for your time and effort!

Best

 

[mikerickson]

This routine promts the user for the size of the base array. That part will need to be changed to meet your situation, but the "choose all possibilities" part of the code might be useful to you.
(Try this on a new worksheet, it clears the worksheet.)

Sub ch_test()
Dim choiceRRay() As Boolean
Dim baseRRay() As String
Dim writeRRay() As String
Dim numObjects As Long
Dim numChoices As Long
Dim i As Long, pointer As Long
Dim writeRange As Range

Set writeRange = ThisWorkbook.Sheets(1).Range("a1")
numObjects = Application.InputBox("Number of objects", Default:=6, Type:=1)
If numObjects < 2 Then Exit Sub
ReDim baseRRay(1 To numObjects)
For i = 1 To numObjects
    baseRRay(i) = Chr(64 + i)
Next i
Set writeRange = writeRange.Resize(1, numObjects)

With writeRange
    .Parent.Cells.ClearContents
    With .Font
        .Underline = xlUnderlineStyleSingle
        .Bold = True
    End With
End With
writeRange.Value = baseRRay

For numChoices = 1 To numObjects
ReDim choiceRRay(1 To numObjects)
For i = 1 To numChoices
    choiceRRay(i) = True
Next i

Do
    Set writeRange = writeRange.Offset(1, 0)
    ReDim writeRRay(1 To numObjects)
    pointer = 0
    For i = 1 To numObjects
        If choiceRRay(i) Then
            pointer = pointer + 1
            writeRRay(pointer) = baseRRay(i)
        End If
    Next i
    writeRange.Value = writeRRay
Loop Until nextChoice(choiceRRay)
Next numChoices
End Sub

Function nextChoice(ByRef choiseRRay() As Boolean) As Boolean
Dim countOfTrue As Long, overflow As Boolean
Dim foundOneTrue As Boolean
Dim lookAt As Long, i As Long
lookAt = LBound(choiseRRay) - 1
Do
    lookAt = lookAt + 1
Loop Until choiseRRay(lookAt)
Do
    choiseRRay(lookAt) = False
    lookAt = lookAt + 1
    countOfTrue = countOfTrue + 1
    If lookAt > UBound(choiseRRay) Then overflow = True: Exit Do
Loop Until Not (choiseRRay(lookAt)) Or overflow
If Not (overflow) Then
    choiseRRay(lookAt) = True
    choiseRRay(lookAt - 1) = False
    For i = LBound(choiseRRay) To countOfTrue - 2 + LBound(choiseRRay)
        choiseRRay(i) = True
    Next i
End If
nextChoice = overflow
End Function

 

[Eric Golf]

Hi,

Manual solution can use binary selection.

Assuming layout as your sheet.

In B4 put:-

=MID(DEC2BIN(ROW()-[B]3[/B],[B]5[/B]),COLUMN()-[B]1[/B],1)

Fill across and down to F34

Result of 1 = included, 0 = not included.

Adjust numbers in bold if using more letters or starting in different cell.

Eric.

 

[valuechained]

Thanks loads! I still playing around with them. Lots of new ideas in there. This will keep me busy for a while.

Thanks again

 

[AJAMES64]

The code sets above are so useful. Thank you very much. It turns out I have lots to learn about excel!!

 

[Henrique]

This routine promts the user for the size of the base array. That part will need to be changed to meet your situation, but the "choose all possibilities" part of the code might be useful to you.
(Try this on a new worksheet, it clears the worksheet.)

Sub ch_test()
Dim choiceRRay() As Boolean
Dim baseRRay() As String
Dim writeRRay() As String
Dim numObjects As Long
Dim numChoices As Long
Dim i As Long, pointer As Long
Dim writeRange As Range
 
Set writeRange = ThisWorkbook.Sheets(1).Range("a1")
numObjects = Application.InputBox("Number of objects", Default:=6, Type:=1)
If numObjects < 2 Then Exit Sub
ReDim baseRRay(1 To numObjects)
For i = 1 To numObjects
    baseRRay(i) = Chr(64 + i)
Next i
Set writeRange = writeRange.Resize(1, numObjects)
 
With writeRange
    .Parent.Cells.ClearContents
    With .Font
        .Underline = xlUnderlineStyleSingle
        .Bold = True
    End With
End With
writeRange.Value = baseRRay
 
For numChoices = 1 To numObjects
ReDim choiceRRay(1 To numObjects)
For i = 1 To numChoices
    choiceRRay(i) = True
Next i
 
Do
    Set writeRange = writeRange.Offset(1, 0)
    ReDim writeRRay(1 To numObjects)
    pointer = 0
    For i = 1 To numObjects
        If choiceRRay(i) Then
            pointer = pointer + 1
            writeRRay(pointer) = baseRRay(i)
        End If
    Next i
    writeRange.Value = writeRRay
Loop Until nextChoice(choiceRRay)
Next numChoices
End Sub
 
Function nextChoice(ByRef choiseRRay() As Boolean) As Boolean
Dim countOfTrue As Long, overflow As Boolean
Dim foundOneTrue As Boolean
Dim lookAt As Long, i As Long
lookAt = LBound(choiseRRay) - 1
Do
    lookAt = lookAt + 1
Loop Until choiseRRay(lookAt)
Do
    choiseRRay(lookAt) = False
    lookAt = lookAt + 1
    countOfTrue = countOfTrue + 1
    If lookAt > UBound(choiseRRay) Then overflow = True: Exit Do
Loop Until Not (choiseRRay(lookAt)) Or overflow
If Not (overflow) Then
    choiseRRay(lookAt) = True
    choiseRRay(lookAt - 1) = False
    For i = LBound(choiseRRay) To countOfTrue - 2 + LBound(choiseRRay)
        choiseRRay(i) = True
    Next i
End If
nextChoice = overflow
End Function

--------------
I am very new to this forum and I need your assistance -- the above macro works well, except for two things, one minor and one major...

Minor) I cannot enter more than 15 values (it crashes in the 16th). I need to enter 28 items!

Major) How hard would it be to enter the actual titles of the items that I want to combine of the letters)?

Thank you very much in advance!
Henrique

p.s. I need to do the combination thing, not the permutation thing -- i.e., ABC = BCA = CBA, etc... and I only need one of them. Thanks!

 

[Eric Golf]

Hi,

Minor) I cannot enter more than 15 values (it crashes in the 16th). I need to enter 28 items!

The reason it probably fails at more than 15 values is it exceeds the number of rows in excel (pre 2007)

I think you have your Minor and Major problems round the wrong way. Replacing 28 values is probably going to be easier than dealing with 268,435,455 possible combinations (2^28)-1 if my maths is correct.

You may have to rethink what you are trying to achieve.

Eric.

 

[Henrique]

Hi,



The reason it probably fails at more than 15 values is it exceeds the number of rows in excel (pre 2007)

I think you have your Minor and Major problems round the wrong way. Replacing 28 values is probably going to be easier than dealing with 268,435,455 possible combinations (2^28)-1 if my maths is correct.

You may have to rethink what you are trying to achieve.

Eric.

Thank you very much Eric. I spent the afternoon thinking about it and also came to the same comclusion you did, but much later.

I have been reading, on and off, your postings and I appreciate all the useful things you all have shared. I am glad to be a new member.

Henrique