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

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
51,165
Office Version
  1. 365
Platform
  1. Windows
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
 

SydneyGeek

MrExcel MVP
Joined
Aug 5, 2003
Messages
12,251
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
 

Brew

Well-known Member
Joined
Sep 29, 2003
Messages
1,569
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?
 

Brew

Well-known Member
Joined
Sep 29, 2003
Messages
1,569

ADVERTISEMENT

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?
 

SydneyGeek

MrExcel MVP
Joined
Aug 5, 2003
Messages
12,251
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
 

SydneyGeek

MrExcel MVP
Joined
Aug 5, 2003
Messages
12,251

ADVERTISEMENT

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
 

jindon

MrExcel MVP
Joined
Aug 21, 2004
Messages
16,995
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
 

agihcam

Well-known Member
Joined
Jan 16, 2006
Messages
1,624
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
 

Brew

Well-known Member
Joined
Sep 29, 2003
Messages
1,569
Thanks gentleman for your solutions, I've chosen agihcam's solution as the best approach
 

Forum statistics

Threads
1,144,364
Messages
5,723,939
Members
422,527
Latest member
TotalBeginner201

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
Top