Permutation in Excel

[ygilbert]

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?

 

[JackBean]

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.

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
	A	B	C	D	E
1	A	1	a		A1a
2	B	2	b		A1b
3	C	3			A2a
4	D				A2b
5					A3a
6					A3b
7					B1a
8					B1b
9					B2a
10					B2b
11					B3a
12					B3b
13					C1a
14					C1b
15					C2a
16					C2b
17					C3a
18					C3b
19					D1a
20					D1b
21					D2a
22					D2b
23					D3a
24					D3b
...

 

[tusharm]

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

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?

 

[James_B]

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)

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

 

[James_B]

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.

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

 

[James_B]

So here it is with a text option:

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

 

[cosmo123]

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.

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.

 

[pgc01]

Hi
Welcome to the board

I just tried it and it worked for me. Can you post an example?

 

[cosmo123]

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?

 

[pgc01]

Hi

The code assumes that the output range is empty.

Maybe you did not clear the output range before running the second time?

 

[cosmo123]

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.