CodeGuru Home VC++ / MFC / C++ .NET / C# Visual Basic VB Forums Developer.com

# Thread: Permutations/Combinations Problem in VBA

1. Junior Member
Join Date
Jul 2004
Posts
2

## Permutations/Combinations Problem in VBA

This is my first posting here so please bear with me if this question has been asked before. I did search the forums and didn't find anything in VBA that resolves pairs of combinations.

Can someone help me with an elusive permutations/combinations problem? I want to generate a list of possible combinations of pairs of (sets of six) letters and numbers.
The total set is made up of six letters and three numbers.

For example:

1 2 3
A
B
C
D
E
F

The first set of six pairs would be:

Set 1 = A1,B1,C1,D1,E1,F1
Set 2 = A1,B1,C1,D1,E1,F2
Set 3 = A1,B1,C1,D1,E1,F3
Set 4 = A1,B1,C1,D1,E2,F1
Set 5 = A1,B1,C1,D1,E3,F1
Set 6 = A1,B1,C1,D1,E2,F2

I would appreciate any code samples in VBA.

Last edited by Jazzike; July 9th, 2004 at 08:38 AM.

2. ## Re: Permutations/Combinations Problem in VBA

Hello,
I dont want to solve your problem exactly but Have a look at this example,I think it could help you,its for Combinatations,if you need Permutations you should ignore check methode
Code:
```//Check for different numbers
int check(int *a,int f,int k,int n)
{
for(int i=f;i<k;i++)
{
if (a[i]==a[k]) return 1;
}
return 0;
}
//Generate all the permutations of a[k]..a[n-1]
//a is an array and n is the lenght of the array
//k is the statrting index for generating permutations
void p(int *a,int k,int n)
{
if(k==n-1)
{
for(int i=0;i<n;i++)
{
Console::Write(a[i]);
}
Console::WriteLine();
}
else
{
for(int i=k;i<n;i++)
{
//if this value differs others generate permutations
if(!check(a,k,i,n))
{
int temp=a[k];a[k]=a[i];a[i]=temp;
p(a,k+1,n);
temp=a[k];a[k]=a[i];a[i]=temp;
}

}
}
}
int _tmain()
{
int a[4];
a[0]=1;
a[1]=0;
a[2]=0;
a[3]=1;
p(a,0,4);
return 0;
}```

if somewhere is unclear ask me,I will explain it in detail....

-----------------
Mehdi.

3. Junior Member
Join Date
Jul 2004
Posts
2

## Re: Permutations/Combinations Problem in VBA

Thanks Mehdi. I already solved the problem by manipulating VBA code but I do appreciate your respose. I will review it and see if it indeed is analogous to my solution.

4. Junior Member
Join Date
Nov 2004
Posts
2

## Re: Permutations/Combinations Problem in VBA

Hi mehdi62b,
Can you tell me how should I implement a program program that can generate combinations of any length chosen from any number of items. In other words, for N numbers generate all possible combinations of K of them.
Would be great to have the answer as soon as possible.
FlBo.

5. ## Re: Permutations/Combinations Problem in VBA

6. Junior Member
Join Date
Nov 2004
Posts
2

## Re: Permutations/Combinations Problem in VBA

Hi mehdi62b,
I will try to addapt what is at the links you gave me. I hope it will be enough.
Bye.

7. Junior Member
Join Date
Apr 2008
Posts
3

## Re: Permutations/Combinations Problem in VBA

Just stumbled upon this, but found the information useful. I adapted the code above to do permutations in Excel VBA.

The algorithm is designed to take a selection of cells (from the Selection object), which should be located in the top row with no data below. The result populates directly below each cell with the permutations of the characters in that cell.

Here is an example. If A1=1234, then beginning in A2 you will have this output:

1234
1243
1324
1342
1432
1423
2134
2143
2314
2341
2431
2413
3214
3241
3124
3142
3412
3421
4231
4213
4321
4312
4132
4123

This is the code, to be placed in standard module. After selecting cells in the top row, run the entry point proc doAllPerms().

Code:
```Const iIncrement As Integer = 1000
Dim PossPerm() As String
Dim iSize As Long
Dim iPos As Long
Dim myStr As String

Public Sub doAllPerms()
Dim rng As Excel.Range

If TypeName(Selection) <> "Range" Then Exit Sub

For Each rng In Selection.Cells
If Len(rng.Value) > 0 Then
Call MakePermutations(rng)
End If
Next rng
End Sub

Private Sub MakePermutations(rng As Excel.Range)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim myArr() As Integer
Dim myPerm() As String

Dim i As Long
Dim j As Long

Dim strTemp As String
myStr = rng.Value

ReDim myArr(0 To Len(myStr) - 1)

For i = LBound(myArr) To UBound(myArr)
myArr(i) = i + 1
Next i

iPos = 1
iSize = iIncrement
ReDim PossPerm(1 To iSize)

Call permuts(myArr, LBound(myArr), UBound(myArr) + 1)

If iPos < iSize Then
iSize = iPos
ReDim Preserve PossPerm(1 To iSize)
End If

ReDim myPerm(LBound(PossPerm) To UBound(PossPerm))

For i = LBound(PossPerm) To UBound(PossPerm)
For j = 1 To Len(PossPerm(i))
myPerm(i) = myPerm(i) & Mid(myStr, CInt(Mid(PossPerm(i), j, 1)), 1)
Next j
Next i

rng.Offset(1, 0).Resize(UBound(myPerm)).Value = _
Application.WorksheetFunction.Transpose(myPerm)

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Private Sub permuts(ByRef myArr() As Integer, k As Integer, n As Integer)
Dim i As Integer
Dim temp As Integer

If (k = n - 1) Then
For i = 0 To n - 1
writeCurrent CStr(myArr(i))
Next i
writeNext
Else
For i = k To n - 1
temp = myArr(k)
myArr(k) = myArr(i)
myArr(i) = temp
Call permuts(myArr, k + 1, n)
temp = myArr(k)
myArr(k) = myArr(i)
myArr(i) = temp
Next i
End If
End Function

Private Sub writeNext()
iPos = iPos + 1
If iPos > iSize Then
iSize = iSize + iIncrement
ReDim Preserve PossPerm(1 To iSize)
End If
End Sub

Private Sub writeCurrent(s As String)
PossPerm(iPos) = PossPerm(iPos) & s
End Sub```
Hopefully this is helpful to someone.
Last edited by iliace; April 9th, 2008 at 01:42 PM.

8. Junior Member
Join Date
May 2008
Posts
1

## Re: Permutations/Combinations Problem in VBA

Hi iliace,
Your code would be very useful to be, but I have a different set-up of the possibilities. I have for example 3 rows which are the entries, but each row consists of 3 columns, that don't need to be changed.
Like this:

1 duck 40
2 frog 60
3 bird 50
The permutations that I would like are:
1 duck 40
2 frog 60
3 bird 50

1 duck 40
3 bird 50
2 frog 60

2 frog 60
1 duck 40
3 bird 50

2 frog 60
3 bird 50
1 duck 40

3 bird 50
1 duck 40
2 frog 60

3 bird 50
2 frog 60
1 duck 40

Is it difficult to adapt your code so I can do this?

9. Junior Member
Join Date
Apr 2008
Posts
3

## Re: Permutations/Combinations Problem in VBA

Call me lazy, but I would just use exact same code (with one minor modification) to create an index, then populate the cells below your range with the permutations based on it. Note that this is no longer compatible with the code I listed for the original purpose.

Select the cells you want, then run doRangePerms().

Code:
```Const iIncrement As Integer = 1000
Dim PossPerm() As String
Dim iSize As Long
Dim iPos As Long
Dim myStr As String

Public Sub doRangePerms()
Application.ScreenUpdating = False
Dim calcs As Excel.XlCalculation
calcs = Application.Calculation
Application.Calculation = Excel.xlCalculationManual

Dim rng As Excel.Range, rngSel As Excel.Range
Dim strPerm As String
Dim i As Long, j As Long
Dim rowPos As Long, rowOffset As Long, colPos As Long

If TypeName(Application.Selection) <> "Range" Then Exit Sub

Set rngSel = Application.Selection

Dim myPerms() As String

For i = 1 To rngSel.Rows.Count
strPerm = strPerm & CStr(i)
Next i

myPerms = MakePermutations(strPerm)

rowOffset = rngSel.Rows.Count + 2
rowPos = rngSel.Cells(1).Offset(rowOffset, 0).Row
colPos = rngSel.Cells(1).Column

For i = LBound(myPerms) To UBound(myPerms)
For j = 1 To Len(myPerms(i))
rngSel.Parent.Cells(rowPos, colPos).Resize(1, _
rngSel.Columns.Count).Value = rngSel.Rows(CLng(Mid\$(myPerms(i), j, 1))).Value
rowPos = rowPos + 1
Next j
rowPos = rowPos + 1
Next i

Application.ScreenUpdating = True
Application.Calculation = calcs
End Sub

Private Function MakePermutations(str As String) As String()
Dim myArr() As Integer
Dim myPerm() As String

Dim i As Long
Dim j As Long

Dim strTemp As String
myStr = str

ReDim myArr(0 To Len(myStr) - 1)

For i = LBound(myArr) To UBound(myArr)
myArr(i) = i + 1
Next i

iPos = 1
iSize = iIncrement
ReDim PossPerm(1 To iSize)

Call permuts(myArr, LBound(myArr), UBound(myArr) + 1)

If iPos < iSize Then
iSize = iPos
ReDim Preserve PossPerm(1 To iSize)
End If

ReDim myPerm(LBound(PossPerm) To UBound(PossPerm))

For i = LBound(PossPerm) To UBound(PossPerm)
For j = 1 To Len(PossPerm(i))
myPerm(i) = myPerm(i) & Mid\$(myStr, CLng(Mid\$(PossPerm(i), j, 1)), 1)
Next j
Next i

MakePermutations = myPerm
End Function

Private Sub permuts(ByRef myArr() As Integer, k As Integer, n As Integer)
Dim i As Integer
Dim temp As Integer

If (k = n - 1) Then
For i = 0 To n - 1
writeCurrent CStr(myArr(i))
Next i
writeNext
Else
For i = k To n - 1
temp = myArr(k)
myArr(k) = myArr(i)
myArr(i) = temp
Call permuts(myArr, k + 1, n)
temp = myArr(k)
myArr(k) = myArr(i)
myArr(i) = temp
Next i
End If
End Sub

Private Sub writeNext()
iPos = iPos + 1
If iPos > iSize Then
iSize = iSize + iIncrement
ReDim Preserve PossPerm(1 To iSize)
End If
End Sub

Private Sub writeCurrent(s As String)
PossPerm(iPos) = PossPerm(iPos) & s
End Sub```
Last edited by iliace; May 27th, 2008 at 12:48 AM.

10. Junior Member
Join Date
Jul 2009
Posts
3

## Re: Permutations/Combinations Problem in VBA

I have zero VBA/coding knowledge but wanted to use the code to generate all possible permuations of the number 12345. I copied the code into the "this workbook" part of the vba screen but ran into a compile error when i ran it. the error said that it "expected an "end sub"" and highlighted the entry "Private Sub permuts(ByRef myArr() As Integer, k As Integer, n As Integer)".

can anyone help?

11. Junior Member
Join Date
Apr 2008
Posts
3

## Re: Permutations/Combinations Problem in VBA

Not sure how that happened. See the correction below. The last line reads End Function, above, hence the error. Change it to End Sub and it should be ok.

Code:
```Private Sub permuts(ByRef myArr() As Integer, k As Integer, n As Integer)
Dim i As Integer
Dim temp As Integer

If (k = n - 1) Then
For i = 0 To n - 1
writeCurrent CStr(myArr(i))
Next i
writeNext
Else
For i = k To n - 1
temp = myArr(k)
myArr(k) = myArr(i)
myArr(i) = temp
Call permuts(myArr, k + 1, n)
temp = myArr(k)
myArr(k) = myArr(i)
myArr(i) = temp
Next i
End If
End Sub```

12. Junior Member
Join Date
Jul 2009
Posts
3

## Re: Permutations/Combinations Problem in VBA

thankyou mr.savior

#### Posting Permissions

• You may not post new threads
• You may not post replies
• You may not post attachments
• You may not edit your posts
•