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.

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

---

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

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

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.

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.

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/algo...cle.php/c5123/

http://www.codeguru.com/Cpp/Cpp/algo...cle.php/c7605/

http://onesearch.sun.com/search/ones...orums&site=dev

Hope they could help you.

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.

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.

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?

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

---

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?

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

---

thankyou mr.savior