
July 9th, 2004, 02:44 AM
#1
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.
Thanks very much in advance.
Last edited by Jazzike; July 9th, 2004 at 08:38 AM.

September 2nd, 2004, 02:54 PM
#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[n1]
//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==n1)
{
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);
Console::Read();
return 0;
}
if somewhere is unclear ask me,I will explain it in detail....

Mehdi.

September 2nd, 2004, 06:07 PM
#3
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.

November 4th, 2004, 12:31 AM
#4
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.
Thanks for your support.
FlBo.

November 4th, 2004, 04:55 AM
#5
Re: Permutations/Combinations Problem in VBA

November 5th, 2004, 12:01 AM
#6
Re: Permutations/Combinations Problem in VBA
Hi mehdi62b,
Thanks for the links. Good luck with your exams.
I will try to addapt what is at the links you gave me. I hope it will be enough.
Bye.

April 9th, 2008, 01:21 PM
#7
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.

May 26th, 2008, 12:49 PM
#8
Re: Permutations/Combinations Problem in VBA
Hi iliace,
Your code would be very useful to be, but I have a different setup 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?

May 27th, 2008, 12:45 AM
#9
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.

July 11th, 2009, 11:10 AM
#10
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?

July 11th, 2009, 11:52 AM
#11
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

July 11th, 2009, 12:27 PM
#12
Re: Permutations/Combinations Problem in VBA
Posting Permissions
 You may not post new threads
 You may not post replies
 You may not post attachments
 You may not edit your posts

Forum Rules

Click Here to Expand Forum to Full Width
OnDemand Webinars (sponsored)
