Permutations/Combinations Problem in VBA

[Jazzike]

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.

[mehdi62b]

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

//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);
Console::Read();
return 0;
}

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

-----------------
Mehdi.:)

[Jazzike]

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.

[FlBo]

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.

[mehdi62b]

Hi FIBo,
I should think of it more,these days I have some hard exams,
I found some links
http://www.codeproject.com/cpp/CombC.asp#xx570098xx

http://www.codeguru.com/Cpp/Cpp/algorithms/article.php/c5123/

http://www.codeguru.com/Cpp/Cpp/algorithms/combinations/article.php/c7605/

http://onesearch.sun.com/search/onesearch/index.jsp?qt=Combinations&qp=siteforumid%3Ajava426&chooseCat=allJava&col=developer-forums&site=dev

Hope they could help you.

[FlBo]

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.

[iliace]

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().

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.

[Gobbomaster]

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?

[iliace]

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().


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

[felix.turton]

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?

[iliace]

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.


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

[felix.turton]

thankyou mr.savior