Listing each different combination configuration

[Brew]

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

 

[Peter_SSs]

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
	C	D	E	F	G	H	I	J	K	L
1									1	1
2									2	2
3									3	3
4									4	1
5									5	3
6	0	5	6		0	5	6		6	2
7	2	3	1		0	6	5		7	2
8	9	4	6		5	0	6		8	1
9					5	6	0		9	3
10					6	0	5		10	2
11					6	5	0		11	3
12					2	3	1		12	1
13					2	1	3		13	3
14					3	2	1		14	1
15					3	1	2		15	2
16					1	2	3		16	3
17					1	3	2		17	2
18					9	4	6		18	1
Combinations

 

[SydneyGeek]

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.

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]

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]

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]

Hi Brew,

try this:

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]

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

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]

Hi
try

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]

how about?

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]

Thanks gentleman for your solutions, I've chosen agihcam's solution as the best approach