I would like to ask you for help with creating a VBA code or python script that would combine all information in below screen like following:
There are 10 columns with in each there is one digit (or a dot). I would like to create a macro that would combine all possible combinations and created a list for me like:
KMFD...BAK
KMHD...BAK
KMJD...BAK
KMFD...CAK
KMFD...CAK
KMHD...CAK
KMJD...CAK
....
....
....
so in short to display me a concataned list whre every digit in each column is combined with every single digit from other columns.
Is that achievable with a macro?
Thank you in advance for any tips.
I would like to creata a VBA
From: VBA - Write all possible combinations of 4 columns of data
Sub ListCombinations()
Dim col As New Collection
Dim c As Range, sht As Worksheet, res
Dim i As Long, arr, numCols As Long
Set sht = ActiveSheet
'lists begin in A2, B2, C2, etc
For Each c In sht.Range("A2:J2").Cells
col.Add Application.Transpose(sht.Range(c, sht.Cells(Rows.Count, c.Column).End(xlUp)))
numCols = numCols + 1
Next c
res = Combine(col, "~~")
For i = 0 To UBound(res)
arr = Split(res(i), "~~")
sht.Range("L1").Offset(i, 0).Resize(1, numCols) = arr
Next i
End Sub
'create combinations from a collection of string arrays
Function Combine(col As Collection, SEP As String) As String()
Dim rv() As String
Dim pos() As Long, lengths() As Long, lbs() As Long, ubs() As Long
Dim t As Long, i As Long, n As Long, ub As Long
Dim numIn As Long, s As String, r As Long, v, tmp()
numIn = col.Count
ReDim pos(1 To numIn)
ReDim lbs(1 To numIn)
ReDim ubs(1 To numIn)
ReDim lengths(1 To numIn)
t = 0
For i = 1 To numIn 'calculate # of combinations, and cache bounds/lengths
'handle cases where only one value in a column (not passed in as array)
If Not TypeName(col(i)) Like "*()" Then
ReDim tmp(1 To 1)
tmp(1) = col(i)
col.Remove i
If i > col.Count Then
col.Add tmp
Else
col.Add tmp, Before:=i
End If
End If
lbs(i) = LBound(col(i))
ubs(i) = UBound(col(i))
lengths(i) = (ubs(i) - lbs(i)) + 1
pos(i) = lbs(i)
t = IIf(t = 0, lengths(i), t * lengths(i))
Next i
ReDim rv(0 To t - 1) 'resize destination array
For n = 0 To (t - 1)
s = ""
For i = 1 To numIn
s = s & IIf(Len(s) > 0, SEP, "") & col(i)(pos(i)) 'build the string
Next i
rv(n) = s
For i = numIn To 1 Step -1
If pos(i) <> ubs(i) Then 'Not done all of this array yet...
pos(i) = pos(i) + 1 'Increment array index
For r = i + 1 To numIn 'Reset all the indexes
pos(r) = lbs(r) ' of the later arrays
Next r
Exit For
End If
Next i
Next n
Combine = rv
End Function
Related
Suppose I have a column of values
1
2
3
4
5
I'm trying to write a VBA function where based on what number I chose(n)
the cells will loop around to that position. So say I i chose 3
Then new list will be
4
5
1
2
3
What I have done is based on each row number, I have tried to develop rules to move the cells but it doesn't seem to be working.. I suspect it's cause I'm using activerow and not the relative row position, but I'm not sure what the syntax is for relative row. Can someone help me out
Option Explicit
Option Base 1
Function DivisibleByN(rng As Range, n As Integer) As Variant
Dim i As Integer, j As Integer
Dim nr As Integer, nc As Integer
Dim B() As Variant
Dim r As ListRow
nr = rng.Rows.Count
nc = rng.Columns.Count
r = ActiveCell.Row
ReDim B(nr, nc) As Variant
For i = 1 To nr
For j = 1 To nc
If r = 1 And r < n Then
B(nr - (n - 1), j) = rng.Cells(i, j)
ElseIf r > 1 And r < n Then
B(nr - (n - r), j) = rng.Cells(i, j)
ElseIf r > n Then
B(r - n, j) = rng.Cells(i, j)
ElseIf r = n Then
B(r, j) = rng.Cells(i, j)
End If
Next j
Next i
DivisibleByN = B
End Function
Assuming you want to "roll" each column individually, you can do something like this:
Public Sub RollColumns(ByVal rng As Range, ByVal rollBy As Integer)
Dim rowsCount As Integer, colsCount As Integer
Dim rowsOffset As Integer, colsOffset As Integer
Dim r As Integer, c As Integer
rowsCount = rng.Rows.Count
colsCount = rng.Columns.Count
rowsOffset = rng.Rows(1).Row - 1
colsOffset = rng.Columns(1).Column - 1
If rowsCount = 1 Then Exit Sub
Dim arr As Variant
arr = rng.Value
For c = 1 To colsCount
For r = 1 To rowsCount
Dim targetIndex As Integer
targetIndex = (r + rollBy) Mod rowsCount
If targetIndex = 0 Then targetIndex = rowsCount
rng.Worksheet.Cells(r + rowsOffset, c + colsOffset).Value = _
arr(targetIndex, c)
Next r
Next c
End Sub
Usage:
RollColumns Range("A1:C5"), 3
See it in action:
you could use this
Function DivisibleByN(rng As Range, n As Integer) As Variant
Dim i As Long, j As Long
With rng
ReDim B(0 To .Rows.Count - 1, 0 To .Columns.Count - 1) As Variant
For i = .Rows.Count To 1 Step -1
For j = 1 To .Columns.Count
B(i - 1, j - 1) = .Cells((.Rows.Count + i - (n + 1)) Mod .Rows.Count + 1, j)
Next
Next
DivisibleByN = B
End With
End Function
This was just to mess around with COM objects and explore them... could be tidied up. S&G moment.
Option Explicit
Public Sub test()
Const n As Long = 3 '<==Add your end point here
Dim arr(), i As Long, rng As Range
With ThisWorkbook.Worksheets("Sheet6") '<==Put your sheet name here
Set rng = .Range("A1:A5") '<== Add your single column range here
Dim maxValue As Variant
Dim minValue As Variant
maxValue = Application.Max(rng)
minValue = Application.Min(rng)
If IsError(maxValue) Or IsError(minValue) Then Exit Sub
If n > maxValue Or n < minValue Then Exit Sub
If rng.Columns.Count > 1 Then Exit Sub
If rng.Cells.Count = 1 Then
ReDim arr(1, 1): arr(1, 1) = rng.Value
Else
arr = rng.Value
End If
Dim list As Object, list2 As Object, queue As Object, arr2()
Set list = CreateObject("System.Collections.ArrayList")
Set queue = CreateObject("System.Collections.Queue")
For i = LBound(arr, 1) To UBound(arr, 1)
list.Add arr(i, 1)
Next
list.Sort
Set list2 = list.Clone
list2.Clear
arr2 = list.GetRange(n, maxValue - n).toArray
For i = LBound(arr2) To UBound(arr2)
queue.enqueue arr2(i)
Next
list2.addRange queue
queue.Clear
arr2 = list.GetRange(0, n).toArray
For i = LBound(arr2) To UBound(arr2)
queue.enqueue arr2(i)
Next
list2.addRange queue
rng.Cells(1, 1).Resize(list2.Count, 1) = Application.WorksheetFunction.Transpose(list2.toArray)
End With
End Sub
This is my current implementation using bits:
Function Array_PowerSet(Self)
Array_PowerSet = Array()
PowerSetUpperBound = -1
For Combination = 1 To 2 ^ (UBound(Self) - LBound(Self)) ' I don't want the null set
Subset = Array()
SubsetUpperBound = -1
For NthBit = 0 To Int(WorksheetFunction.Log(Combination, 2))
If Combination And 2 ^ NthBit Then
SubsetUpperBound = SubsetUpperBound + 1
ReDim Preserve Self(0 To SubsetUpperBound)
Subset(SubsetUpperBound) = Self(NthBit)
End If
Next
PowerSetUpperBound = PowerSetUpperBound + 1
ReDim Preserve Array_PowerSet(0 To PowerSetUpperBound)
Array_PowerSet(PowerSetUpperBound) = Subset
Next
End Function
Please ignore the abuse of Variants. Array_Push and Array_Size should be self-explanatory.
Previously, I was generating a binary string for each combination, but that involved calling another function which wasn't very efficient.
Aside from using less Variants and moving external function calls inside, is there any way I can make this more efficient?
EDIT: Here's a fully independent version.
Function Array_PowerSet(Self As Variant) As Variant
Dim PowerSet() As Variant, PowerSetIndex As Long, Size As Long, Combination As Long, NthBit As Long
PowerSetIndex = -1: Size = UBound(Self) - LBound(Self) + 1
ReDim PowerSet(0 To 2 ^ Size - 2) ' Don't want null set
For Combination = 1 To 2 ^ Size - 1
Dim Subset() As Variant, SubsetIndex As Long: SubsetIndex = -1
For NthBit = 0 To Int(WorksheetFunction.Log(Combination, 2))
If Combination And 2 ^ NthBit Then
SubsetIndex = SubsetIndex + 1
ReDim Preserve Subset(0 To SubsetIndex)
Subset(SubsetIndex) = Self(NthBit)
End If
Next
PowerSetIndex = PowerSetIndex + 1
PowerSet(PowerSetIndex) = Subset
Next
Array_PowerSet = PowerSet
End Function
And a test:
Dim Input_() As Variant, Output_() As Variant, Subset As Variant, Value As Variant
Input_ = Array(1, 2, 3)
Output_ = Array_PowerSet(Input_)
For Each Subset In Output_
Dim StringRep As String: StringRep = "{"
For Each Value In Subset
StringRep = StringRep & Value & ", "
Next
Debug.Print Left$(StringRep, Len(StringRep) - 2) & "}"
Next
Since the number of subsets grows exponentially, no algorithm is truly efficient, although there is room for improvement in what you are doing:
ReDim Preserve, when used to extend an array by a single item, is inefficient since it involves creating a new array with 1 more space and then copying the old elements to the new array. It is better to pre-allocate enough space and then trim it down to size:
Function PowerSet(Items As Variant) As Variant
'assumes that Items is a 0-based array
'returns a 0-based jagged array of subsets of Items
'where each subset is a 0-based array
Dim PS As Variant
Dim i As Long, j As Long, k As Long, n As Long
Dim subset As Variant
n = 1 + UBound(Items) 'cardinality of the base set
ReDim PS(0 To 2 ^ n - 2)
For i = 1 To 2 ^ n - 1
subset = Array()
ReDim subset(0 To n - 1)
k = -1 'will be highest used index of the subset
For j = 0 To n - 1
If i And 2 ^ j Then
k = k + 1
subset(k) = Items(j)
End If
Next j
ReDim Preserve subset(0 To k)
PS(i - 1) = subset
Next i
PowerSet = PS
End Function
A test function:
Sub test()
Dim stuff As Variant, subsets As Variant
Dim i As Long
stuff = Array("a", "b", "c", "d")
subsets = PowerSet(stuff)
For i = LBound(subsets) To UBound(subsets)
Cells(i + 1, 1).Value = "{" & Join(subsets(i), ",") & "}"
Next i
End Sub
Using collections to build your sets is an option...
Function Generator()
Dim Arr() As Variant: Arr = Array(1, 2, 3, 4)
Dim PSCol As Collection: Set PSCol = PowerSetCol(Arr)
Dim SubSet As Collection, SubSetStr As String
For i = 1 To PSCol.Count
Set SubSet = PSCol.Item(i)
SubSetStr = "{"
For j = 1 To SubSet.Count
SubSetStr = SubSetStr & SubSet.Item(j) & IIf(j = SubSet.Count, "", ", ")
Next j
SubSetStr = SubSetStr & "}"
Debug.Print SubSetStr
Next i
End Function
Function PowerSetCol(Arr As Variant) As Collection
Dim n As Long, i As Long
Dim Temp As New Collection, SubSet As Collection
For i = 1 To 2 ^ (UBound(Arr) + 1) - 1
Set SubSet = New Collection
For n = 0 To UBound(Arr)
If i And 2 ^ n Then SubSet.Add Arr(n)
Next n
Temp.Add SubSet
Next i
Set PowerSetCol = Temp
End Function
******* EDIT ********
Apparently accessing collections through index is more intensive than enumerating through the items. Also; you can't use join directly as stated by #John Coleman but a single line function can be used in it's place.
Hopefully the code below is a more optimal solution
Function Generator()
Dim Arr() As Variant: Arr = Array(1, 2, 3, 4)
Dim PSColl As Collection: Set PSColl = PowerSetColl(Arr)
Dim Str As String, Coll As Collection, Item As Variant
For Each Coll In PSColl
Str = ""
For Each Item In Coll
Str = strJoin(", ", Str, CStr(Item))
Next Item
Debug.Print "{" & Str & "}"
Next Coll
End Function
Function PowerSetColl(Arr As Variant) As Collection
Dim Temp As New Collection, SubSet As Collection
Dim n As Long, i As Long
For i = 1 To 2 ^ (UBound(Arr) + 1) - 1
Set SubSet = New Collection
For n = 0 To UBound(Arr)
If i And 2 ^ n Then SubSet.Add Arr(n)
Next n
Temp.Add SubSet
Next i
Set PowerSetColl = Temp
End Function
Function strJoin(Delimiter As String, Optional Str1 As String, Optional Str2 As String) As String
strJoin = IIf(IsMissing(Str1) Or Str1 = "", Str2, IIf(IsMissing(Str2) Or Str2 = "", Str1, Str1 & Delimiter & Str2))
End Function
I have a requirement where in, I need to use the auto filter to filter the data first and then am using the advanced filter to get the Unique values alone. But the advanced filter doesn't take the auto filtered value alone. How do I use them together?
Here goes my code,
Colmz = WorksheetFunction.Match("RSDate", Sheets("RS_Report").Rows(1), 0)
ActiveSheet.ListObjects("RS").Range.AutoFilter Field:=Colmz, Criteria1:="YES"
ActiveSheet.Range("B1:B65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("CSRS").Range("B14"), Unique:=True
Kindly correct me and share your suggestions. Thanks
I would stick the unique values in an array - it's faster and less likely to break -
sub uniquearray()
Colmz = WorksheetFunction.Match("RSDate", Sheets("RS_Report").Rows(1), 0)
ActiveSheet.ListObjects("RS").Range.AutoFilter Field:=Colmz, Criteria1:="YES"
Call creatary(curary, Sheets("RS_Report"), Letter(Sheets("RS_Report"), "RSDate")): Call eliminateDuplicate(curary): Call BuildArrayWithoutBlankstwo(curary): Call Alphabetically_SortArray(curary)
For Each cell In curary
'do what you need to do with the unique array list
Next cell
end sub
Function creatary(ary As Variant, sh As Worksheet, ltr As String)
Dim x, y, rng As Range
ReDim ary(0)
Set rng = sh.Range(ltr & "2:" & ltr & sh.Range("A1000000").End(xlUp).Row).SpecialCells(xlCellTypeVisible)
x = 0
For Each y In rng
If Not Application.IsError(y) Then
If Not IsNumeric(y) Then
ary(x) = y
End If
x = x + 1
ReDim Preserve ary(x)
End If
Next y
End Function
Function BuildArrayWithoutBlankstwo(ary As Variant)
Dim AryFromRange() As Variant, AryNoBlanks() As Variant
Dim Counter As Long, NoBlankSize As Long
'set references and initialize up-front
ReDim AryNoBlanks(0 To 0)
NoBlankSize = 0
'load the range into array
AryFromRange = ary
'loop through the array from the range, adding
'to the no-blank array as we go
For Counter = LBound(AryFromRange) To UBound(AryFromRange)
If ary(Counter) <> 0 Then
NoBlankSize = NoBlankSize + 1
AryNoBlanks(UBound(AryNoBlanks)) = ary(Counter)
ReDim Preserve AryNoBlanks(0 To UBound(AryNoBlanks) + 1)
End If
Next Counter
'remove that pesky empty array field at the end
If UBound(AryNoBlanks) > 0 Then
ReDim Preserve AryNoBlanks(0 To UBound(AryNoBlanks) - 1)
End If
'debug for reference
ary = AryNoBlanks
End Function
Function eliminateDuplicate(ary As Variant) As Variant
Dim aryNoDup(), dupArrIndex, i, dupBool, j
dupArrIndex = -1
For i = LBound(ary) To UBound(ary)
dupBool = False
For j = LBound(ary) To i
If ary(i) = ary(j) And Not i = j Then
dupBool = True
End If
Next j
If dupBool = False Then
dupArrIndex = dupArrIndex + 1
ReDim Preserve aryNoDup(dupArrIndex)
aryNoDup(dupArrIndex) = ary(i)
End If
Next i
ary = aryNoDup
End Function
Function Alphabetically_SortArray(ary)
Dim myArray As Variant
Dim x As Long, y As Long
Dim TempTxt1 As String
Dim TempTxt2 As String
myArray = ary
'Alphabetize Sheet Names in Array List
For x = LBound(myArray) To UBound(myArray)
For y = x To UBound(myArray)
If UCase(myArray(y)) < UCase(myArray(x)) Then
TempTxt1 = myArray(x)
TempTxt2 = myArray(y)
myArray(x) = TempTxt2
myArray(y) = TempTxt1
End If
Next y
Next x
ary = myArray
End Function
Function Letter(oSheet As Worksheet, name As String, Optional num As Integer)
If num = 0 Then num = 1
Letter = Application.Match(name, oSheet.Rows(num), 0)
Letter = Split(Cells(, Letter).Address, "$")(1)
End Function
Aisle 1 Aisle 2 Aisle 3 Aisle 4 Aisle 5 Aisle 6 Aisle 7 Aisle 8 Aisle 9 Aisle 10
Apple Apple Towels Soap Cans Cans Forks Shampoo Toys Chips
Orange Tomato Boxes Clean Bottles Cups Knives B Wash Games Snacks
Pear Potato Plates Spoons Candy
Pina
Above listed are the columns that I need to have all possible combinations.
Here is the macro that i have now:
Sub Aisles()
Dim col As New Collection
Dim c As Range, sht As Worksheet, res
Dim i As Long, arr, numCols As Long
Set sht = ActiveSheet
For Each c In sht.Range("A4:J4").Cells
col.Add Application.Transpose(sht.Range(c, c.End(xlDown)))
numCols = numCols + 1
Next c
res = Combine(col, "~~")
For i = 0 To UBound(res)
arr = Split(res(i), "~~")
sht.Range("L3").Offset(i, 0).Resize(1, numCols) = arr
Next i
End Sub
Function Combine(col As Collection, SEP As String) As String()
Dim rv() As String
Dim pos() As Long, lengths() As Long, lbs() As Long, ubs() As Long
Dim t As Long, i As Long, n As Long, ub As Long
Dim numIn As Long, s As String, r As Long
numIn = col.Count
ReDim pos(1 To numIn)
ReDim lbs(1 To numIn)
ReDim ubs(1 To numIn)
ReDim lengths(1 To numIn)
t = 0
For i = 1 To numIn 'calculate # of combinations, and cache bounds/lengths
lbs(i) = LBound(col(i))
ubs(i) = UBound(col(i))
lengths(i) = (ubs(i) - lbs(i)) + 1
pos(i) = lbs(i)
t = IIf(t = 0, lengths(i), t * lengths(i))
Next i
ReDim rv(0 To t - 1) 'resize destination array
For n = 0 To (t - 1)
s = ""
For i = 1 To numIn
s = s & IIf(Len(s) > 0, SEP, "") & col(i)(pos(i)) 'build the string
Next i
rv(n) = s
For i = numIn To 1 Step -1
If pos(i) <> ubs(i) Then 'Not done all of this array yet...
pos(i) = pos(i) + 1 'Increment array index
For r = i + 1 To numIn 'Reset all the indexes
pos(r) = lbs(r) ' of the later arrays
Next r
Exit For
End If
Next i
Next n
Combine = rv
End Function
There are 2 things that I need help with:
I need to allow only 1 item listed in a column. As it is ,the macro requires at least 2 items to be listed in the column in order to work.
I need the macro to exclude an item once it is chosen: for example in column 1 "apple" is listed and also in column 2. As well is "cans" in columns 5 and 6. Apples can not be stored in 2 different aisles. I guess this might be called a permutation? So the final list of combinations does not have any repeating items.
With no dupes and switching to a 2-d array as the return type, which is much cleaner.
Sub Aisles()
Dim col As New Collection
Dim c As Range, sht As Worksheet, res
Dim i As Long, arr, numCols As Long
Dim rng As Range
Set sht = ActiveSheet
For Each c In sht.Range("A4:J4").Cells
Set rng = sht.Range(c, sht.Cells(Rows.Count, c.Column).End(xlUp))
If rng.CountLarge > 1 Then
col.Add Application.Transpose(sht.Range(c, c.End(xlDown)))
Else
'deal with case where there's only a single value in the column
col.Add Array(c.Value)
End If
numCols = numCols + 1
Next c
res = CombineNoDups(col)
sht.Range("L3").Offset(i, 0).Resize(UBound(res, 1), _
UBound(res, 2)).Value = res
End Sub
Function CombineNoDups(col As Collection)
Dim rv(), tmp()
Dim pos() As Long, lengths() As Long, lbs() As Long, ubs() As Long
Dim t As Long, i As Long, n As Long, ub As Long, x As Long
Dim numIn As Long, s As String, r As Long, v, dup As Boolean
numIn = col.Count
ReDim pos(1 To numIn)
ReDim lbs(1 To numIn)
ReDim ubs(1 To numIn)
ReDim lengths(1 To numIn)
t = 0
For i = 1 To numIn 'calculate # of combinations, and cache bounds/lengths
lbs(i) = LBound(col(i))
ubs(i) = UBound(col(i))
lengths(i) = (ubs(i) - lbs(i)) + 1
pos(i) = lbs(i)
t = IIf(t = 0, lengths(i), t * lengths(i))
Next i
ReDim rv(1 To t, 1 To numIn) 'resize destination array
x = 0
For n = 1 To t
ReDim tmp(1 To numIn)
dup = False
For i = 1 To numIn
v = col(i)(pos(i))
If Not IsError(Application.Match(v, tmp, 0)) Then
dup = True
Exit For
Else
tmp(i) = v
End If
Next i
If Not dup Then
x = x + 1
For i = 1 To numIn
rv(x, i) = tmp(i)
Next i
End If
For i = numIn To 1 Step -1
If pos(i) <> ubs(i) Then 'Not done all of this array yet...
pos(i) = pos(i) + 1 'Increment array index
For r = i + 1 To numIn 'Reset all the indexes
pos(r) = lbs(r) ' of the later arrays
Next r
Exit For
End If
Next i
Next n
CombineNoDups = rv
End Function
I have a mapping program that maps versioned language-codes from one version to another. The program maps the codes correctly with one caveat, working with combination codes. I have parsed the mapping files and have gotten far enough as to structure arrays with the options per node and calculate the number of possibilities given the data.
Consider the following data:
CodeA translates to: Array(1,1) = "CodeB|CodeC|CodeD|"
Array(1,2) = "CodeE|"
Array(1,3) = "CodeF|CodeG|"
What this means is that CodeA translates to (CodeB or CodeC or CodeD) with codeE with (CodeF or CodeG)
The code first calculates the # of possibilites (above has 6) then dims an array to fit the resulted strings. I need the stored strings to be all combinations of the mapping, i.e.:
CodeB with CodeE with CodeF
CodeB with CodeE with CodeG
CodeC with CodeE with CodeF
CodeC with CodeE with CodeG
CodeD with CodeE with CodeF
CodeD with CodeE with CodeG
The code needs to work with all different sizes of arrays with multiple mappings. The above example is simple, but it can get more complicated, like this:
CodeA translates to: Array(1,1) = "CodeB|CodeC|CodeD|"
Array(1,2) = "CodeE|"
Array(1,3) = "CodeF|CodeG|"
Array(2,1) = "CodeH|"
Array(2,2) = "CodeI|CodeJ|"
Array(2,3) = "CodeK|CodeL|CodeM|CodeN|"
Array(2,4) = "CodeO|"
Array(3,1) = "CodeQ|"
Array(3,2) = "CodeR|CodeS|"
Which means CodeA translates to: ((CodeB or CodeC or CodeD) with CodeE with (CodeF or CodeG)) or (CodeH with (CodeI or CodeJ) with (CodeK or CodeL or CodeM or CodeN) with CodeO) or (CodeQ with (CodeR or CodeS)) --- 96 combinations
The program will already know the max first subscript, so the code would look something like:
for i = 1 to maxSubOne
GET_COMBINATIONS(Array(i))
next i
Any suggestions?
I think this works...
EDIT: updated Combine() to make it insensitive to the base of the arrays contained in the submitted collection and change Do-Loop for For-Next
Sub Tester()
Dim arr(1 To 3, 1 To 4)
arr(1, 1) = "CodeB|CodeC|CodeD|"
arr(1, 2) = "CodeE|"
arr(1, 3) = "CodeF|CodeG|"
arr(2, 1) = "CodeH|"
arr(2, 2) = "CodeI|CodeJ|"
arr(2, 3) = "CodeK|CodeL|CodeM|CodeN|"
arr(2, 4) = "CodeO|"
arr(3, 1) = "CodeQ|"
arr(3, 2) = "CodeR|CodeS|"
DoCombinations arr
End Sub
Sub DoCombinations(arr As Variant)
Dim r As Long, c As Long
Dim nc As Long, nr As Long
Dim a
Dim col As Collection, col2 As New Collection
Dim final() As String, tmp
nr = UBound(arr, 1)
nc = UBound(arr, 2)
For r = 1 To nr 'loop through first dimension
Set col = New Collection
For c = 1 To nc
tmp = arr(r, c)
If Len(tmp) > 0 Then
'remove any trailing "|"
If Right(tmp, 1) = "|" Then
tmp = Left(tmp, Len(tmp) - 1)
End If
col.Add Split(tmp, "|")
End If
Next c
col2.Add Combine(col, "-")
Next r
'intermediate arrays
For Each a In col2
Debug.Print "-----Intermediate-----"
Debug.Print Join(a, vbLf)
Next a
final = Combine(col2 "-") 'final combination...
Debug.Print "-----Final-----"
Debug.Print Join(final, vbCrLf)
End Sub
'create combinations from a collection of string arrays
Function Combine(col As Collection, SEP As String) As String()
Dim rv() As String
Dim pos() As Long, lengths() As Long, lbs() As Long, ubs() As Long
Dim t As Long, i As Long, n As Long, ub As Long
Dim numIn As Long, s As String, r As Long
numIn = col.Count
ReDim pos(1 To numIn)
ReDim lbs(1 To numIn)
ReDim ubs(1 To numIn)
ReDim lengths(1 To numIn)
t = 0
For i = 1 To numIn 'calculate # of combinations, and cache bounds/lengths
lbs(i) = LBound(col(i))
ubs(i) = UBound(col(i))
lengths(i) = (ubs(i) - lbs(i)) + 1
pos(i) = lbs(i)
t = IIf(t = 0, lengths(i), t * lengths(i))
Next i
ReDim rv(0 To t - 1) 'resize destination array
For n = 0 To (t - 1)
s = ""
For i = 1 To numIn
s = s & IIf(Len(s) > 0, SEP, "") & col(i)(pos(i)) 'build the string
Next i
rv(n) = s
For i = numIn To 1 Step -1
If pos(i) <> ubs(i) Then 'Not done all of this array yet...
pos(i) = pos(i) + 1 'Increment array index
For r = i + 1 To numIn 'Reset all the indexes
pos(r) = lbs(r) ' of the later arrays
Next r
Exit For
End If
Next i
Next n
Combine = rv
End Function