CodeGuru Home VC++ / MFC / C++ .NET / C# Visual Basic VB Forums Developer.com
Results 1 to 12 of 12
  1. #1
    Join Date
    Jul 2004
    Posts
    2

    Question 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.

  2. #2
    Join Date
    Sep 2004
    Location
    Tehran(Ir)
    Posts
    469

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

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

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

  3. #3
    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. #4
    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.
    Thanks for your support.
    FlBo.

  5. #5
    Join Date
    Sep 2004
    Location
    Tehran(Ir)
    Posts
    469

    Re: Permutations/Combinations Problem in VBA


  6. #6
    Join Date
    Nov 2004
    Posts
    2

    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.

  7. #7
    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. #8
    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. #9
    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. #10
    Join Date
    Jul 2009
    Posts
    3

    Unhappy 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. #11
    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. #12
    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
  •  





Click Here to Expand Forum to Full Width

Featured