All possible combinations of data inputted under three headings

[Randy]

I wonder whether anyone is so inclined to offer their suggestion as to
how one might accomplish the following...

(A snippet of code for a macro is great by the way, if anyone thinks
they might have an idea.) I'm using Excel 2007, and am at a sort of
junior moderate level of proficiency with the VBA after a good number
of years at it on a part-time basis.


DEFINITION of issue:
I would like to use Excel to populate data into individual cells
corresponding to three individual (and unrelated) headings, and once
finished, enter a simple keystroke (ie. execute a macro) that would
produce an output of every possible combination the data in the cells
inputted under each of the headings. The icing on the cake of this
plan would be if the input interface for this process could be
presented to the user in the form of a three-dimensional look with
three axes (although I don't know if Excel 2007 can do it). However,
the three dimensional look is a luxury designed to enhance user
friendliness... and in fact a two dimensional, 'good old normal Excel
look' is just fine.

ANALOGY of problem:
Imagining a three dimensional object – for instance a cube - would be
the best way to describe an ideal input interface for this, and to
really understand the idea here. Were it possible (and perhaps it is
not) to have Excel present cells by width (on a y-axis, that is), AND
by length (on an x-axis) AND by height (on a z-axis), with
corresponding rows (or columns, whatever the case may be) of cells
running along each axis, the user would have a friendly interface to
use to populate cells along each axis, until he's inputted all of his
data. At the conclusion of the inputting, the data in each cell along
each axis is processed and consequently (after selecting a keystroke,
that is) outputted with every possible combination displayed in a
single column of cells showing the individual results, separately (one
result per cell), as the output, on either a separate worksheet or new
workbook.

SPECIFICS

The input process...

1) The user begins entering data in the second cell along each axis
(eg. A2).
2) The user can enter any combination of alphanumeric data in a cell,
and/or leave spaces.
3) The user must not skip a cell along any axis (eg. By filling in A7
and A9, but leaving A8 blank).
4) The user may elect not to not input data in the cells running along
one axis (with the result, for instance, that cells along the x-axis
and z-axis are populated with data, yet no cells along the y-axis are
populated).
5) The user may input data in more or less cells along one axis than
along another (eg. user inputs data in three cells along the x-axis, 2
cells along the y-axis and 4 cells along the z-axis).

The output...

1) The data inputted into each cell is presented, in output, in every
possible combination with the data from the other cells.
2) A single space is left between each set of data, in the outputted
format (ie. Tree Car Blue, not TreeCarBlue)
3) The integrity of the data in the cell itself is preserved (ie. if
“Tree” is the input data, it is not then outputted in a shorter form
such as “Tre” or “T”, in addition to being outputted as "Tree")
4) The combinations in the output ought to include using the data in a
cell under one heading (ie. along one axis, that is), and:
a) placing it in front of the data in each of the cells under the same
heading;
b) placing it behind the data in each of the cells under the same
heading;
c) placing it in front of the data in each of the cells under each of
the other headings;
d) placing it in behind the data in each of the cells under each of
the other headings;
e) placing it between the data from each of the other cells under the
other headings;
.... and any other possible combining pattern that one can think of to
produce the result that every possible combination is shown in the
output.
5) There ought not to be duplicate entries of exactly the same output.


EXAMPLE (of inputs, and some of the resulting output):

Inputs:

Along the cells on x-axis:
X2: Tree
X3: Flower

Along the cells on y-axis:
Y2: Car

Along the cells on z-axis:
Z2: Blue
Z3: Yellow

Output (in first column of fresh worksheet or workbook):

A1: Tree Flower
A2: Flower Tree
A3: Tree Car
A4: Car Tree
A5: Tree Blue
A6: Blue Tree
A7: Tree Yellow
A8: Yellow Tree
A9: Tree Flower Car
A10: Tree Car Flower
A11: Tree Blue Car
A12: Tree Blue Flower Car
A13: Tree Yellow Flower Car
A14: Tree Blue Yellow Car Flower
A15: Car Yellow Flower Tree Blue

etc… (until all combinations are shown)


Many thanks, by the way, to the highly skilled MVPs and other persons
of great intellect who have made this group a success for so many
years now. You guys are great and I truly aspire to such greatness.
It's no easy feat!

 

[r]

Option Explicit
Dim RE As Object

Sub Start_routine()
Dim rng1 As Excel.Range
Dim rng2 As Excel.Range
Dim rng3 As Excel.Range
Dim rngT As Excel.Range
Dim rngR As Excel.Range
Dim L As Long

Set rng1 = [a1:a3]
Set rng2 = [b1]
Set rng3 = [c1:c3]
Set rng1 = Application.Union(rng1, rng2, rng3)
Set rngR = Nuovo_Range(ThisWorkbook)

For Each rng2 In rng1
For Each rngT In rng2
If Not IsEmpty(rngT.Value) Then
rngR.Offset(L) = rngT
L = L + 1
End If
Next
Next

Set RE = CreateObject("VBScript.RegExp")

Combina_Dic rngR.Parent.UsedRange, rngR

End Sub


Sub Combina_Dic( _
sC As Range, _
StartRng As Excel.Range)
'di Roberto Mensa - Nick r

Dim dic1 As Object
Dim L1 As Long, L2 As Long
Dim S1 As String, S2 As String
Dim v1 As Variant

Set dic1 = CreateObject("Scripting.dictionary")
L1 = sC.Count

For L2 = 1 To L1
dic1.Add sC(L2), ""
Debug.Print sC(L2)
S2 = S2 & sC(L1) & " "
Next

S2 = Trim(S2)

For Each v1 In dic1
For L2 = 1 To L1
S1 = v1 & " " & sC(L2)
dic1.Add S1, ""
Next
If S1 = S2 Then Exit For
Next

L2 = 0
For Each v1 In dic1
If Is_Unique_RE(CStr(v1)) Then
StartRng.Offset(L2) = v1
L2 = L2 + 1
End If
Next

End Sub


Function Is_Unique_RE(Testo As String) As Boolean
'di Roberto Mensa - Nick r

Dim M, s As String

RE.Global = True
RE.IgnoreCase = True
RE.Pattern = "\w+"
For Each M In RE.Execute(Testo)
RE.Pattern = "\b" & M & "\b"
If RE.test(s) Then
Exit Function
Else
s = s & " " & M
End If
Next
Is_Unique_RE = True
End Function


Function Nuovo_Range( _
Wb As Excel.Workbook, _
Optional Nome_base As _
String = "Res") As Excel.Range
'di Roberto Mensa - Nick r

Dim b
Set Nuovo_Range = Wb.Worksheets.Add.Range("A1")

Application.ScreenUpdating = False
On Error Resume Next
Do
Err.Clear
Nuovo_Range.Parent.Name = Nome_base & b
b = b + 1
Loop While Err
Application.ScreenUpdating = True

End Function


regards
r

Il mio ultimo lavoro ...
http://excelvba.altervista.org/blog/index.php/Excel-VBA/UsedRange-eccezioni-e-alternative.html