Permutations/Combinations of a set of numbers

[bridgesmadeofsweets]

Hello,

I have looked through the forum for existing answers to this but can't find a response that I understand enough to modify to my own design.

Basically I want to output every combination of a set of numbers. These permutations must include combinations that use only a few of the numbers as well as all eight...ie.

1,
1,2
1,2,3
as well as 1,2,3,4,5,6,7,8

The macro below is from
http://www.j-walk.com/ss/excel/tips/tip46.htm
This only produces combinations using every number. I'm not sure how this macro works but hopefully someone with better know how could run with it or break it down for me!

I only need to achieve this once but am pretty sure doing it manually will cause error and or madness!

Any help would be much appreciated!</PRE>
Kind Regards</PRE>
Joe</PRE>


Dim CurrentRowSub 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 IfEnd SubSub GetPermutation(x As String, y As String)' The source of this algorithm is unknown 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 IfEnd Sub</PRE>
</PRE>

 

[bridgesmadeofsweets]

Thanks for your help everyone - I'll try these out in the morning and let you know how it goes!

Joe

 

[tusharm]

If I understand you correctly, you want what is called a superset. Also, there is a distinct difference between what is called a combination and a what is called a permutation. You seem to be using the two interchangeably.

You should check
Powerset, Subset, and Combinations & Permutations
http://www.tushar-mehta.com/excel/tips/powerset.html

Hello,

I have looked through the forum for existing answers to this but can't find a response that I understand enough to modify to my own design.

Basically I want to output every combination of a set of numbers. These permutations must include combinations that use only a few of the numbers as well as all eight...ie.

1,
1,2
1,2,3
as well as 1,2,3,4,5,6,7,8

The macro below is from
http://www.j-walk.com/ss/excel/tips/tip46.htm
This only produces combinations using every number. I'm not sure how this macro works but hopefully someone with better know how could run with it or break it down for me!

I only need to achieve this once but am pretty sure doing it manually will cause error and or madness!

Any help would be much appreciated!</PRE>
Kind Regards</PRE>
Joe</PRE>


{snip of unformatted code}

 

[mikerickson]

This follows the flow chart I posted above.
The "Yes, display results" option handles showing more results than there are rows and is the slowest part of the routine.

The array PermutationsOfSizeElements is arranged so that the permuation array P is the first n! elements of PermutationsOfSizeElements.

Sub MAIN()
    Dim BaseArray() As String
    Dim PermutationsOfSizeElements As Variant, permIndex As Long
    Dim subSet As Variant, subSetIndex As Long
    Dim pointer As Long, i As Long
    Dim resultArray As Variant
    Dim Size As Long
    
    Size = Application.InputBox("Size", Default:="8", Type:=1)
    
    Rem create BaseArray  {"a", "b", "c",..,"h"}
        ReDim BaseArray(1 To Size)
        For i = 1 To Size
            BaseArray(i) = Chr(96 + i)
        Next i
        
    Rem create P(n)
        PermutationsOfSizeElements = PermutationsOf(Size)
        
    pointer = 0
    ReDim resultArray(1 To 1)
    
    Rem loop through subsets
    For subSetIndex = 1 To (2 ^ Size) - 1
    
        subSet = ChooseFrom(BaseArray, subSetIndex)
        
        Rem loop through P(UBound(subSet))
        For permIndex = 1 To Application.Fact(UBound(subSet))
            pointer = pointer + 1
            If UBound(resultArray) < pointer Then ReDim Preserve resultArray(1 To 2 * pointer)
            resultArray(pointer) = PermActingOn(PermutationsOfSizeElements(permIndex), subSet)
        Next permIndex
        
    Next subSetIndex
    
    ReDim Preserve resultArray(1 To pointer)
    
    Rem display results
        If MsgBox(pointer & " combinations found" & vbCr & "Display results?", vbYesNo) = vbYes Then
            permIndex = 0
            subSetIndex = 1
            Application.ScreenUpdating = False
            Cells.ClearContents
            For pointer = 1 To UBound(resultArray)
                permIndex = permIndex + 1
                If permIndex > 10000 Then
                    permIndex = 1
                    subSetIndex = subSetIndex + 2
                End If
                Cells(permIndex, subSetIndex) = resultArray(pointer)
            Next pointer
            Application.ScreenUpdating = True
        End If
End Sub

Function PermutationsOf(N As Long) As Variant
    Dim aPerm() As Long
    Dim Permutations() As Variant
    Dim pointer As Long, i As Long, j As Long
    Dim prevMax As Long, currentSize As Long
    
    ReDim Permutations(1 To Application.Fact(N))
    ReDim aPerm(1 To N)
    
    Rem make identity permuation
    Permutations(1) = aPerm
    For i = 1 To N
    Permutations(1)(i) = i
    Next i
    
    Rem construct others
    pointer = 1
    prevMax = 1
    For currentSize = 2 To N
        For i = 1 To prevMax
            For j = 1 To currentSize - 1
                pointer = pointer + 1
                Permutations(pointer) = Permutations(i)
                Permutations(pointer)(currentSize) = Permutations(i)(j)
                Permutations(pointer)(j) = Permutations(i)(currentSize)
            Next j
        Next i
        prevMax = pointer
    Next currentSize
    
    PermutationsOf = Permutations
End Function

Function PermActingOn(perm As Variant, myArray As Variant) As String
    Dim i As Long
    For i = LBound(myArray) To UBound(myArray)
        PermActingOn = PermActingOn & myArray(perm(i))
    Next i
End Function

Function ChooseFrom(ByVal myArray As Variant, ByVal choiceNumber As Long) As Variant
    Dim resultArray As Variant, i As Long, aPointer As Long
    ReDim resultArray(1 To UBound(myArray))
    For i = 1 To UBound(myArray)
        If 0 < (choiceNumber And (2 ^ (i - 1))) Then
            aPointer = aPointer + 1
            resultArray(aPointer) = myArray(i)
        End If
    Next i
    ReDim Preserve resultArray(1 To aPointer)
    ChooseFrom = resultArray
End Function

 

[bridgesmadeofsweets]

Thanks for the link tusharm -I wish I had seen that before!
I was conscious that I was blantantly misusing language - and therefore thanks to everyone for endeavouring to help despite this!

mikerickson - that works so perfectly!

i just changed the line

BaseArray(i) = Chr(96 + i)

to

BaseArray(i) = Chr(48 + i)

so now I get the exact list I was searching for!

That is brilliant! - I am very very grateful!

Thank you so much!

Joe/

 

[thisisrahul]

hi all,
i was just going through this wonderful application of VB to create combinations of a given numbers.
one problem that i am facing is this code is giving combinations of alphabets. i tried searching to change the array to integer but could not find.

can somebodcy suggest me how to get combinations of integers.


____________
Rahul

 

[bridgesmadeofsweets]

As noted above - the code:

BaseArray(i) = Chr(96 + i)

is saying 'use the characters above 96' ie. the lower case alphabet.

if you change that to:

BaseArray(i) = Chr(48 + i)

it will use numbers instead.

 

[mikerickson]

If you set BaseArray to the letters on the 8 tiles,
changing this will restrict resultArray to those words that are in your dictionary.

For subSetIndex = 1 To (2 ^ Size) - 1
    Rem loop through P(UBound(subSet))
    For permIndex = 1 To Application.Fact(UBound(subSet))
        [COLOR="Red"]If Application.CheckSpelling(word:=resultArray(Pointer)) Then
            Pointer = Pointer + 1
        End If[/COLOR]
        If UBound(resultArray) < Pointer Then ReDim Preserve resultArray(1 To 2 * Pointer)
        resultArray(Pointer) = PermActingOn(PermutationsOfSizeElements(permIndex), subSet)
    Next permIndex
    
    [COLOR="red"]If Not Application.CheckSpelling(word:=resultArray(Pointer)) Then
        Pointer = Pointer - 1
    End If[/COLOR]
Next SubSetIndex

 

[bridgesmadeofsweets]

That sounds amazing!

Have I read the code correctly - this uses the built-in dictionary to check spelling? - That would make my document about 50mb smaller! - wow!

I made the changes but I'm getting a 'subscript out of range' error message...is there anything else I need to define or change to make this run correctly?

 

[mikerickson]

I think this will do it. There may be a need to be further protection against the case where none of the possible words is in the Dictionary. (e.g. no vowels)

For subSetIndex = 1 To (2 ^ Size) - 1
    Rem loop through P(UBound(subSet))
    For permIndex = 1 To Application.Fact(UBound(subSet))
        If UBound(resultArray) < Pointer Then ReDim Preserve resultArray(1 To 2 * Pointer)
        resultArray(Pointer) = PermActingOn(PermutationsOfSizeElements(permIndex), subSet)
        [COLOR="Red"]Pointer = Pointer + CLng(Not (Application.CheckSpelling(word:=resultArray(Pointer))))[/COLOR]
    Next permIndex
    
Next SubSetIndex

 

[ajetrumpet]

If anyone is still looking for an answer to this, I posted it on another site:

http://www.access-programmers.co.uk/forums/showthread.php?t=168546