Listing each different combination configuration

Brew

Well-known Member
Joined
Sep 29, 2003
Messages
1,569
Is there a formula or code that will take each 3 digit combination in the range C6:E90 and place the 6 different ways each combination can be configured into columns G, H, I, starting with row 6.
Example:
If c6:e6=056
Then, G6:I11=056,065,506,560,605,650
And if c7:e7=231
Then, G12:I17=231,213,321,312,123,132
and so on

Each digit is different within the combination, there are no duplicates
 

Excel Facts

How to create a cell-sized chart?
Tiny charts, called Sparklines, were added to Excel 2010. Look for Sparklines on the Insert tab.
Brew

I think a vba solution may the best here, but it is not my strong point so here is one possible formula solution:

1. I have added a 'helper' table in K1:L18
2. Formula in G6 (copied across and down):
=INDEX($C$6:$E$8,1+INT((ROWS(G$6:G6)-1)/6),VLOOKUP(3*MOD(ROWS(G$6:G6)-1,6)+COLUMNS($G6:G6),$K$1:$L$18,2,0))

Colour has been added manually to aid checking of results.
Mr Excel.xls
CDEFGHIJKL
111
222
333
441
553
605605662
723106572
894650681
956093
10605102
11650113
12231121
13213133
14321141
15312152
16123163
17132172
18946181
Combinations
 
Upvote 0
Brew,

Here is some code to do the trick.
Note: It is hard-wired to do PERMUT(3,3) permutations.
Place in a code module, run by returning to Excel, pressing Alt + F8 and double-clicking the macro name.
Code:
Sub PermutArray()
    Dim Token(1 To 3) As Variant
    Dim vOut(1 To 3) As Variant
    Dim vArray() As Variant
    Dim x As Long, m As Long
    Dim K As Long, i As Long
    K = WorksheetFunction.Permut(3, 3)
    
    x = Range("C:C").SpecialCells(xlCellTypeConstants).Count * K
    ReDim vArray(1 To x, 1 To 3)
    Dim Rw As Long
    Dim c As Range
    Rw = Range("C65536").End(xlUp).Row
    
    m = 1
    For Each c In Range("C6:C" & Rw)
        Token(1) = c.Value
        Token(2) = c.Offset(0, 1).Value
        Token(3) = c.Offset(0, 2).Value
        For i = 1 To K
            vOut(1) = Token(3)
            vOut(2) = Token(1)
            vOut(3) = Token(2)
            
            Token(1) = vOut(1)
            Token(2) = vOut(2)
            Token(3) = vOut(3)
            
            vArray(m, 1) = Token(1)
            vArray(m, 2) = Token(2)
            vArray(m, 3) = Token(3)
            m = m + 1
        Next i
    Next c
    Range("G6").Resize(x, 3) = vArray
End Sub
Denis
 
Upvote 0
I have not test the formula version, though I agree that code may be the best approach.
The code solution:
When I used the test data in
c6:e6=056
I should have gotten G6:I11=056,065,506,560,605,650
but I got 605,560,056,605,560,056 (605,560, and 056 repeated)

I should have following: for each row: cde, ced, dce, dec, ecd, edc
Can the code be reformatted to get this result or is there another solution?
 
Upvote 0
I think Peter and Sydney have retired for the evening and our offline. Is there anyone else that has a code modification that would solve this problem?
 
Upvote 0
Hi Brew,

try this:
Code:
Sub PermutArray_v2()
    Dim Token(1 To 3) As Variant
    Dim vOut(1 To 3) As Variant
    Dim vArray() As Variant
    Dim x As Long, m As Long
    Dim K As Long, i As Long
    K = WorksheetFunction.Permut(3, 3)
    x = Range("C:C").SpecialCells(xlCellTypeConstants).Count * K
    ReDim vArray(1 To x, 1 To 3)
    Dim Rw As Long
    Dim c As Range
    Rw = Range("C65536").End(xlUp).Row
    
    m = 1
    For Each c In Range("C6:C" & Rw)
        Token(1) = c.Value
        Token(2) = c.Offset(0, 1).Value
        Token(3) = c.Offset(0, 2).Value
        
        'this is ugly but does the job...
        '1
        vArray(m, 1) = Token(1)
        vArray(m, 2) = Token(2)
        vArray(m, 3) = Token(3)
        m = m + 1
        '2
        Call FlipElements(Token, 1, 2)
        vArray(m, 1) = Token(1)
        vArray(m, 2) = Token(2)
        vArray(m, 3) = Token(3)
        m = m + 1
        '3
        Call FlipElements(Token, 2, 3)
        vArray(m, 1) = Token(1)
        vArray(m, 2) = Token(2)
        vArray(m, 3) = Token(3)
        m = m + 1
        '4
        Call FlipElements(Token, 1, 2)
        vArray(m, 1) = Token(1)
        vArray(m, 2) = Token(2)
        vArray(m, 3) = Token(3)
        m = m + 1
        '5
        Call FlipElements(Token, 2, 3)
        vArray(m, 1) = Token(1)
        vArray(m, 2) = Token(2)
        vArray(m, 3) = Token(3)
        m = m + 1
        '6
        Call FlipElements(Token, 1, 2)
        vArray(m, 1) = Token(1)
        vArray(m, 2) = Token(2)
        vArray(m, 3) = Token(3)
        m = m + 1
    Next c
    Range("G6").Resize(x, 3) = vArray
End Sub

Private Sub FlipElements(varArray As Variant, _
 item1 As Integer, item2 As Integer)
    Dim Temp As Variant
    Dim i As Integer

    Temp = varArray(item2)
    varArray(item2) = varArray(item1)
    varArray(item1) = Temp
End Sub
Denis
 
Upvote 0
Here's a more general solution.
Adjust RANGE_SIZE to suit the number of items to grab
Adjust your output column so that it doesn't step on the input
Works with text values as well
Do not exceed 65536 permutations

Code:
Dim Perm() As Variant

Sub PermutArray_v3()
    Dim vArray() As Variant
    Dim X As Long, m As Long
    Dim K As Long, i As Long, j As Long, b As Long
    Const RANGE_SIZE = 3 'numbers to permute
    Dim Token(1 To RANGE_SIZE) As Variant
    Dim vOut(1 To RANGE_SIZE) As Variant
    K = WorksheetFunction.Permut(RANGE_SIZE, RANGE_SIZE)
    X = Range("C:C").SpecialCells(xlCellTypeConstants).Count * K
    Dim Rw As Long
    Dim c As Range
    Rw = Range("C65536").End(xlUp).Row
    ReDim vArray(1 To X, 1 To RANGE_SIZE)
    
    'create all positional permutations for PERMUT(N,N) where N = RANGE_SIZE
    GenPermutations (RANGE_SIZE)
    
    m = 1
    For Each c In Range("C6:C" & Rw)
        For b = 1 To RANGE_SIZE
            Token(b) = c.Offset(0, b - 1).Value
        Next b
        
        'using GenPermutations to get all options...
        For j = 1 To K
            For i = 1 To RANGE_SIZE
                vArray(m, i) = Token(Perm(j, i))
            Next i
            m = m + 1
        Next j
    Next c
    Range("G6").Resize(X, RANGE_SIZE) = vArray
End Sub

Sub GenPermutations(ByVal N As Long)
   '
   ' "Johnson-Trotter" VB6 implementation by MathImagics (Dec 2004)
   '   Each permutation is obtained from the previous by
   '   swapping just ONE pair of adjacent items.
   '   Adapted 6 Sep 2006 by SydneyGeek
   '   to write permutations out to an array.

   Dim Item()   As Long   ' items to permute
   Dim Link()   As Long   ' 0 = link left, 1 = right
   Dim j        As Long
   Dim K As Long, kSpot As Long  ' largest mobile K and its position
   Dim P As Long, pSpot As Long  ' iterator value P, its position
   Dim mobile   As Boolean         ' "mobility" test flag
   Dim kLink    As Long
   Dim X As Long, Z As Long
   Z = WorksheetFunction.Permut(N, N)
   '
   ' 0. Setup initial state
   '
   ReDim Item(N), Link(N)
   ReDim Perm(1 To Z, 1 To N)
   For j = 1 To N
      Item(j) = j
      Next
   Z = 1
   Do
      '
      ' 1. report current permutation
      '
      For j = 1 To N
        Perm(Z, j) = Item(j)
      Next j
      Z = Z + 1
      '
      ' 2. select "mobile" position with highest value
      '
      K = 0
      pSpot = 0

      Do While pSpot < N
         pSpot = pSpot + 1
         P = Item(pSpot)

         mobile = False

         If Link(pSpot) = 0 Then
            If pSpot > 1 Then
               If Item(pSpot - 1) < P Then mobile = True
               End If
         ElseIf pSpot < N Then
            If Item(pSpot + 1) < P Then mobile = True
            End If
         
         If mobile Then
            If P > K Then
               K = P
               kSpot = pSpot
               If K = N Then Exit Do ' look no further
               End If
            End If
         Loop

       If K = 0 Then Exit Do  ' all done!

       '
       ' 3.  Swap item kSpot with "neighbour"
       '
       kLink = Link(kSpot)
       If kLink Then
          Item(kSpot) = Item(kSpot + 1): Link(kSpot) = Link(kSpot + 1)
          Item(kSpot + 1) = K:           Link(kSpot + 1) = 1
       Else
          Item(kSpot) = Item(kSpot - 1): Link(kSpot) = Link(kSpot - 1)
          Item(kSpot - 1) = K:           Link(kSpot - 1) = 0
          End If
       '
       ' 4. Toggle Links for any items > K
       '
       For pSpot = 1 To N
          If Item(pSpot) > K Then Link(pSpot) = 1 - Link(pSpot)
          Next
       Loop
   End Sub
Denis
 
Upvote 0
Hi
try
Code:
Sub test()
Dim a, result(), n As Long, t As Long
Dim i As Long, ii As Integer, iii As Integer, iv As Integer
      a=Range("c6",Range("c" & Rows.Count).End(xlUp)).Resize(,3).Value
      For i = 1 To UBound(a,1)
          ReDim result(1 To 6,1 To 1) : n = 0
          For ii = 1 To 3
                For iii = 1 To 3
                     For iv = 1 To 3
                         If (ii <> iii) * (iii <> iv) * (ii <> iv) Then
                             n = n + 1
                             result(n,1) = a(i,ii) & a(i, iii) & a(i,iv)
                         End If
                      Next
                 Next
           Next
           Range("g" & 6 + t).Resize(6) = result
           t = t + 6
      Next
End Sub
 
Upvote 0
how about?
Code:
Sub sample()
Dim i As Long
Application.ScreenUpdating = False
Range("g5:i" & Rows.Count).ClearContents
Range("g5").Resize(, 3).Value = Array("h1", "h2", "h3")
For i = 6 To Range("c" & Rows.Count).End(xlUp).Row
Range("g" & Rows.Count).End(xlUp).Offset(1).Resize(, 3) = Array(Cells(i, "c"), Cells(i, "d"), Cells(i, "e"))
Range("g" & Rows.Count).End(xlUp).Offset(1).Resize(, 3) = Array(Cells(i, "c"), Cells(i, "e"), Cells(i, "d"))
Range("g" & Rows.Count).End(xlUp).Offset(1).Resize(, 3) = Array(Cells(i, "d"), Cells(i, "c"), Cells(i, "e"))
Range("g" & Rows.Count).End(xlUp).Offset(1).Resize(, 3) = Array(Cells(i, "d"), Cells(i, "e"), Cells(i, "c"))
Range("g" & Rows.Count).End(xlUp).Offset(1).Resize(, 3) = Array(Cells(i, "e"), Cells(i, "c"), Cells(i, "d"))
Range("g" & Rows.Count).End(xlUp).Offset(1).Resize(, 3) = Array(Cells(i, "e"), Cells(i, "d"), Cells(i, "c"))
Next
Range("g5").Resize(, 3).ClearContents
Application.ScreenUpdating = True
End Sub
 
Upvote 0
Thanks gentleman for your solutions, I've chosen agihcam's solution as the best approach
 
Upvote 0

Forum statistics

Threads
1,217,675
Messages
6,137,925
Members
450,099
Latest member
Pushbutton

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