Enumerating Text; making combinations

[gal4y]

I have users input a list of alternatives for specific functions in their project. Example (The letters represent the alternatives):

Each alternative takes up one cell in Excel.

Function 1 Function 2 Function 3
A B C
D E F

I would like to combine these possible alternatives to look like this and place the contents into another worksheet (each alternative would still take up only one cell):

A B C
A B F
A E C
A E F
D B C
D B F
D E C
D E F

How do accomplish the looping for this. The user is asked how many functions (columns) and the maximum number of alternatives in one alternative column (rows).

Each column may not be even because it is based on brainstorming. For example:

Function 1 Function 2 Function 3
A B C
D E
F


For this example, I realize that some duplication would take effect based on blanks but I am not worried about it:

A B C
A B
A B
A E C
A E
A E
A C
A
A
D B C
D B
D B
D E C
D E
D E
D C
D
D
F B C
F B
F B
F E C
F E
F E
F C
F
F

Thank you for your assistance in advance
Greg

 

[Zathras]

This macro will do what you want. The restrictions are:
Data area must begin in cell "A1"
Data area must have column titles
Longest column must be column "A"
Must have a blank row at bottom of data area
Must have a blank column at right of data area
[blue]

Option Explicit

Sub ConcatenateAlternatives()

[green]

' Assumes table begins in cell "A1" on Sheet1 with titles
' Also assumes longest column is column "A"
' Requires blank row at bottom and blank column on right

[/color]

Dim r As Range
Dim nRows As Integer
Dim nCols As Integer
Dim x As Integer
Dim y As Integer
Dim z As Integer
Dim nCurrentRow As Integer

[green]

  ' Get shape of input data

[/color]

  Worksheets("Sheet1").Activate
  Set r = Range("A1").CurrentRegion
  nRows = r.Rows.Count
  nCols = r.Columns.Count

[green]

  ' Set up destination area with headings and first column

[/color]

  Worksheets("Sheet2").Activate
  Range(Cells(1, 1), Cells(1, nCols)).EntireColumn.Clear
  r.Range(r.Cells(1, 1), r.Cells(1, nCols)).Copy Cells(1, 1)
  r.Range(r.Cells(2, 1), r.Cells(nRows + 1, 1)).Copy Cells(2, 1)

[green]

  ' Build composite matrix

[/color]

  Application.ScreenUpdating = False
  For x = 2 To nCols
    nCurrentRow = 2
    While Cells(nCurrentRow, x - 1) <> &quot;&quot;
      Cells(nCurrentRow, x) = r.Cells(2, x)
      For y = 3 To nRows
        Cells(nCurrentRow, 1).EntireRow.Insert
        nCurrentRow = nCurrentRow + 1
        Cells(nCurrentRow, 1).EntireRow.Copy Cells(nCurrentRow - 1, 1)
        Cells(nCurrentRow, x) = r.Cells(y, x)
      Next y
      nCurrentRow = nCurrentRow + 1
    Wend
  Next x
  Set r = Nothing
  Application.ScreenUpdating = True
  Cells(1, 1).Select
End Sub

[/color]

 

[Zathras]

Oops. Bug! Please replace the line that begins [blue]

 While

[/color] with the following:
[blue]

   While Cells(nCurrentRow, 1) <> &quot;&quot;

[green]

 ' <----- correction

[/color]
[/color]
Sorry for the confusion.

 

[gal4y]

Thank you so much I will try it out.
I appreciate you assistance.

Greg