Permutation in Excel

Y

ygilbert

New Member
Joined
Jul 12, 2008
Messages
44
I have the following:

(A,B,C,D) and (1,2,3) and (X,Y,Z)

So I would like to get the following combinations

A1X,A1Y,A1Z, A2X,A2Y,A2Z, ..., D3X,D3Y,D3Z

How is this done in excel?
 
Sort by date Sort by votes
This was a good problem, and good for close to a week's worth of fun.
And it took me close to that to catch up to pgc01, with his nice demonstration of recursion.
I will be on the lookout to use that.

I have added pgc01's idea of putting the result in column to the right of the items to permute, and put the result of each permutation in one cell.
Both this version and pgc01's prior post give the same result as below.

Code: 
Sub Perm()
Dim lCol As Long, lRow As Long, V As Long, X As Long, Y As Long, Z As Long
Dim vIn As Variant, vOut As Variant
With Range("A1").CurrentRegion
    lCol = .Columns.Count
    lRow = .Rows.Count
    vIn = .Value
    Cells.ClearContents
    .Value = vIn
End With
If lRow ^ lCol > Rows.Count Then
    MsgBox "Not Enough Rows In Spreadsheet"
    Exit Sub
End If
vOut = Range("A1").Resize(lRow ^ lCol, 1)
For V = 2 To lCol
    Z = 0
    For X = 1 To lRow ^ lCol
        If IsEmpty(vOut(X, 1)) Then Exit For
        For Y = 1 To lRow
            If IsEmpty(vIn(Y, V)) Then Exit For
            Z = Z + 1
            Cells(Z, lCol + 2) = vOut(X, 1) & vIn(((Y - 1) Mod lRow) + 1, V)
        Next Y
    Next X
    If V< lCol Then vOut = Cells(1, lCol + 2).Resize(lRow ^ lCol, 1)
Next V
End Sub
Excel Workbook
ABCDE
1A1aA1a
2B2bA1b
3C3A2a
4DA2b
5A3a
6A3b
7B1a
8B1b
9B2a
10B2b
11B3a
12B3b
13C1a
14C1b
15C2a
16C2b
17C3a
18C3b
19D1a
20D1b
21D2a
22D2b
23D3a
24D3b
...
 
Upvote 0

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.
You have already received several suggestions. Here are a few generalized approaches.
Generate All Permutations
http://www.tushar-mehta.com/publish_train/xl_vba_cases/generate_all_permutations.htm

Powerset, Subset, and Combinations & Permutations
http://www.tushar-mehta.com/excel/tips/powerset.html

ygilbert said:
I have the following:

(A,B,C,D) and (1,2,3) and (X,Y,Z)

So I would like to get the following combinations

A1X,A1Y,A1Z, A2X,A2Y,A2Z, ..., D3X,D3Y,D3Z

How is this done in excel?
Click to expand...
 
Upvote 0
Not necessarily the best, but here's a way of generating numerical permutations that should prove fairly quick (and can easily be extended to text)

Code: 
Option Explicit
 
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" ( _
   nDestPtr As Any, _
   nSrcPtr As Any, _
   ByVal nLenB As Long _
)
Private Declare Sub ZeroMemory Lib "kernel32.dll" Alias "RtlZeroMemory" ( _
   nDestPtr As Any, _
   ByVal nLenB As Long _
)
 
Private Sub foo()
 
   Dim v As Variant
   v = PermsOf(Array(4, 3, 5, 6))
   ActiveSheet.Cells(1, 1).Resize(UBound(v, 1), UBound(v, 2)).Value = v
End Sub
 
Private Function PermsOf(vDims As Variant) As Variant
 
   Dim nRows      As Long, _
       nCols      As Long, _
       nDims      As Long
 
   Dim iDim       As Long, _
       nReps      As Long, _
       nUnitLen   As Long, _
       iRep       As Long
 
   Dim nConst     As Long, _
       nDestPos   As Long
 
   Dim sTmp       As String, _
       vTmp       As Variant, _
       rTmp       As Range
 
   Dim vRes As Variant
 
   ' Prep vars and RE-BASE vDims for convenience
   ReDim Preserve vDims(1 To UBound(vDims) - LBound(vDims) + 1)
   nDims = UBound(vDims)
   nReps = 1
 
   ' Size up an OUTPUT array
   ReDim vRes(1 To Application.Product(vDims), 1 To nDims)
 
   ' Loop dimensions
   For iDim = 1 To nDims
 
      ' Calc NUM of REPEATED UNITs as CUMULATIVE prod of prev dims
      If iDim < nDims Then
         nReps = nReps * vDims(iDim)
      Else
         nReps = UBound(vRes, 1) \ vDims(nDims)
      End If
 
      ' Calc UNIT LENGTH and define appropriate range
      nUnitLen = UBound(vRes, 1) \ nReps
      Set rTmp = ActiveSheet.Cells(1, 1).Resize(nUnitLen)
 
      ' For each unit,...
      For iRep = 1 To nReps
 
         ' Use nConst to vary the repeated unit
         If iDim < nDims Then
 
            nConst = ((iRep - 1) Mod (vDims(iDim))) + 1
            sTmp = "=(ROW(" & rTmp.Address & ") = 0) + " & nConst
         Else
 
            sTmp = "=ROW(" & rTmp.Address & ")"
         End If
 
         vTmp = Evaluate(sTmp)
 
         ' Calc ROW OF RES ARRAY to write vTmp to
         nDestPos = (iRep - 1) * nUnitLen + 1
 
         ' Copy to approp COL of vRES
         CopyMemory ByVal VarPtr(vRes(nDestPos, iDim)), _
                    ByVal VarPtr(vTmp(1, 1)), UBound(vTmp) * 16
         ZeroMemory ByVal VarPtr(vTmp(1, 1)), UBound(vTmp) * 16
      Next iRep
 
   Next iDim
 
   PermsOf = vRes
   ZeroMemory ByVal VarPtr(vRes(1, 1)), UBound(vRes, 1) * UBound(vRes, 2)
End Function
 
Last edited:
Upvote 0
For anyone who's interested, here's a cleaned-up version, more along the lines of what I was after in the first place. I didn't realise that Excel formulas use a kind of inbuilt singleton expansion, i.e. that adding a (1 x n) to a (m x 1) vector yields a (m x n) matrix.

Code: 
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" ( _
   nDestPtr As Any, _
   nSrcPtr As Any, _
   ByVal nLen As Long _
)
Private Declare Sub ZeroMemory Lib "kernel32.dll" Alias "RtlZeroMemory" ( _
   pbDest As Any, _
   ByVal nLen As Long _
)
Private Sub foo()
   
   Dim v As Variant
   v = PermsOf(Array(4, 3, 5, 6))
   ActiveSheet.Cells(1, 1).Resize(UBound(v, 1), UBound(v, 2)).Value = v
End Sub

Private Function PermsOf(vDims As Variant) As Variant
   
   Dim nDims      As Long, _
       iDim       As Long, _
       nReps      As Long, _
       nUnitLen   As Long, _
       iRep       As Long
   
   Dim nDestPos   As Long
   
   Dim sTmp       As String, _
       vTmp       As Variant, _
       rTmp       As Range
   
   Dim vRes As Variant
   
   ' Prep vars and RE-BASE vDims for convenience
   ReDim Preserve vDims(1 To UBound(vDims) - LBound(vDims) + 1)
   nDims = UBound(vDims)
   
   ' Size up an OUTPUT array
   ReDim vRes(1 To Application.Product(vDims), 1 To nDims)
      
   ' Loop through vRes's dimensions
   For iDim = 1 To nDims
   
      ' Calc NUMBER of REPEATED UNITs we need
      Select Case iDim
         Case 1, nDims
            nReps = 1
         
         Case Else
            nReps = nReps * vDims(iDim - 1)
      End Select
      
      ' Calc UNIT LENGTH and define appropriate range
      nUnitLen = UBound(vRes, 1) \ nReps
      Set rTmp = ActiveSheet.Cells(1, 1).Resize(nUnitLen \ vDims(iDim), vDims(iDim))
      
      ' Define FORMULA as FIRST ROW PLUS FIRST COL
      sTmp = "=COLUMN(" & rTmp.Rows(1).Address & ") + " & _
             "(ROW(" & rTmp.Columns(1).Address & ") = 0)"
      vTmp = Evaluate(sTmp)
      
      ' Transpose on FINAL LOOP
      If iDim = nDims Then vTmp = Application.Transpose(vTmp)
      
      ' For each unit,...
      For iRep = 1 To nReps
               
         ' Calc ROW OF RES ARRAY to write vTmp to
         nDestPos = (iRep - 1) * nUnitLen + 1
         
         ' Copy to approp COL of vRES
         CopyMemory ByVal VarPtr(vRes(nDestPos, iDim)), _
                    ByVal VarPtr(vTmp(1, 1)), rTmp.Cells.Count * 16
      Next iRep
      
   Next iDim
   
   ' Make a copy of vRes
   PermsOf = vRes
   
   ' Clear vRes and vTmp, since they have OVERLAPPING POINTERS
   ZeroMemory ByVal VarPtr(vTmp(1, 1)), UBound(vTmp, 1) * UBound(vTmp, 2)
   ZeroMemory ByVal VarPtr(vRes(1, 1)), UBound(vRes, 1) * UBound(vRes, 2)
End Function
 
Upvote 0
So here it is with a text option:

Code: 
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" ( _
   nDestPtr As Any, _
   nSrcPtr As Any, _
   ByVal nLen As Long _
)
Private Declare Sub ZeroMemory Lib "kernel32.dll" Alias "RtlZeroMemory" ( _
   pbDest As Any, _
   ByVal nLen As Long _
)
Private Sub foo()
   
   Dim v As Variant
   v = PermsOf( _
          Array(4, 3, 5, 6) _
       )
   ActiveSheet.Cells(1, 1).Resize(UBound(v, 1), UBound(v, 2)).Value = v
End Sub

Private Function PermsOf(ByRef vDims As Variant, _
                         Optional ByVal rTxtSrc As Range) As Variant
   
   Dim nDims      As Long, _
       nReps      As Long, _
       nUnitLen   As Long
   
   Dim iDim       As Long, _
       iRep       As Long
   
   Dim nDestPos   As Long
   
   Dim sTmp       As String, _
       vTmp       As Variant, _
       rTmp       As Range
   
   Dim vRes As Variant
   
   ' Prep vars and RE-BASE vDims for convenience
   ReDim Preserve vDims(1 To UBound(vDims) - LBound(vDims) + 1)
   nDims = UBound(vDims)
   
   ' Size up an OUTPUT array
   ReDim vRes(1 To Application.Product(vDims), 1 To nDims)
      
   ' Loop through vRes's dimensions
   For iDim = 1 To nDims
   
      ' Calc NUMBER of REPEATED UNITs we need
      Select Case iDim
         Case 1, nDims
            nReps = 1
         
         Case Else
            nReps = nReps * vDims(iDim - 1)
      End Select
      
      ' Calc UNIT LENGTH and define appropriate range
      nUnitLen = UBound(vRes, 1) \ nReps
      Set rTmp = ActiveSheet.Cells(1).Resize(nUnitLen \ vDims(iDim), vDims(iDim))
      
      ' Define FORMULA as FIRST ROW PLUS FIRST COL
      sTmp = "=COLUMN(" & rTmp.Rows(1).Address & ") + " & _
             "(ROW(" & rTmp.Columns(1).Address & ") = 0)"
      vTmp = Evaluate(sTmp)
      
      ' Transpose on FINAL LOOP
      If iDim = nDims Then vTmp = Application.Transpose(vTmp)
      
      ' For each unit,...
      For iRep = 1 To nReps
               
         ' Calc ROW OF RES ARRAY to write vTmp to
         nDestPos = (iRep - 1) * nUnitLen + 1
         
         ' Copy to approp COL of vRES
         CopyMemory ByVal VarPtr(vRes(nDestPos, iDim)), _
                    ByVal VarPtr(vTmp(1, 1)), rTmp.Cells.Count * 16
      Next iRep
      
   Next iDim
      
   
   ' If TEXT is needed, then..
   If Not rTxtSrc Is Nothing Then
      
      Dim bCheckCols As Boolean, _
          bCheckRows As Boolean
      
      ' VALIDATE text source
      bCheckCols = rTxtSrc.Columns.Count >= nDims
      bCheckRows = rTxtSrc.Rows.Count >= Application.Max(vDims)
      
      If bCheckCols And bCheckRows Then
      
         Dim vTxt    As Variant
         vTxt = rTxtSrc.Value
      
         Dim iRow    As Long, _
             iCol    As Long
         For iRow = 1 To UBound(vRes, 1)
         
            For iCol = 1 To UBound(vRes, 2)
                     
               ' Replace number with TEXT
               CopyMemory ByVal VarPtr(vRes(iRow, iCol)), _
                          ByVal VarPtr(vTxt(vRes(iRow, iCol), iCol)), 16
            Next iCol
         Next iRow
      
         ZeroMemory ByVal VarPtr(vTxt(1, 1)), UBound(vTxt, 1) * UBound(vTxt, 2) * 16
      End If
         
   End If
   
   ' Make a copy of vRes
   PermsOf = vRes
   
   ' Clear vRes and vTmp, since they have OVERLAPPING POINTERS
   ZeroMemory ByVal VarPtr(vTmp(1, 1)), UBound(vTmp, 1) * UBound(vTmp, 2) * 16
   ZeroMemory ByVal VarPtr(vRes(1, 1)), UBound(vRes, 1) * UBound(vRes, 2) * 16
End Function
 
Upvote 0
pgc01 said:
Hi

Another option, using vba.

This should work with any number of sets, each with any number of elements.

Write the sets in contiguous columns, starting in column A. Write each set in contiguous rows starting in row 1. Leave the column after the last set empty.
Click to expand...
Hi pgc01. I just tried this code and it works very well if each set has 2 or more elements. If some sets have just 1 element it doesn't work. I think it's just a small adjustment to the code but I can't figure out how to do it. Much appreciated if you can adjust this code to include the special case where one or more sets have just 1 element.
 
Upvote 0
Hi
Welcome to the board

I just tried it and it worked for me. Can you post an example?
 
Upvote 0
Hi pgc01. Have a look here (you can download the file).

Now delete the d2 element in column D and run the sub again. Notice how the list still includes permutations with d1 and d2 even though there should only be d1.

If I delete the G-K columns and then run the sub, the results are correct.

By the way, is it possible to run the sub automatically every time there are changes in columns A-E rather than having to run it manually every time?
 
Last edited:
Upvote 0
Hi

The code assumes that the output range is empty.

Maybe you did not clear the output range before running the second time?
 
Upvote 0
Indeed I did not. Is there a way to change it so it clears the range automatically. Also, is it possible that it does this every time something changes in the input range? It is cumbersome to have to run it manually. The input area is populated by some functions that collect data from other sheets.
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Solved
How to combine IF and FILTER formulas to copy text from one column to another
Replies
4
Views
242
Fluff
Fluff
S
  • Solved
Excel: Accumulated data from other sheets that grows as each supplier sheet grows
Replies
7
Views
208
Fluff
Fluff
L
  • Question
User Defined Formula to Generate Polynomial Regression Equation
Replies
1
Views
444
Dave Patton
D
M
  • Solved
MAP / LAMBDA Functions to get multiple array elements
Replies
3
Views
124
Domenic
D
R
  • Question
Applying a formula to a subset of rows
Replies
3
Views
147
rodqntr
R

Forum statistics

Threads
1,215,054
Messages
6,122,895
Members
449,097
Latest member
dbomb1414

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top