I have a serious problem with resizing a 2-dimensional array in VBA. I've done a lot of reading about this (popular) issue, but still I can't figure out what's wrong in my code.
So, I have some data in a spreadsheet. In the second row I have some descriptions of an element, while in the first row I have categories of those elements. What I want to do is create an array which has (distinct) categories in the first row and indexes of descriptions related to a particular category in the second row.
The code works correctly up until
If j = UBound(distinctList, 2) Then
Then ReDim comes in and I get a "Subscript out of range error".
That If is there to add a new category and is meant to kick in if the entry from the spreadsheet does not equal any entry from the new array.
Function distinctValues(arr)
Dim distinctList() As String
Dim j As Integer
k = 0
'ReDim distinctList(0 To 0, 0 To 1)
'Dodaj pierwszy wpis
For i = LBound(arr) To UBound(arr)
If arr(i) <> "" Then
ReDim distinctList(0 To 1, 0 To j)
distinctList(0, 0) = arr(i)
distinctList(1, 0) = i + 1
'k = k + 1
Exit For
End If
Next i
'Dodaj kolejne wpisy
For i = LBound(arr) + 1 To UBound(arr)
If arr(i) <> "" Then
For j = LBound(distinctList, 2) To UBound(distinctList, 2)
If arr(i) = distinctList(0, j) Then
distinctList(1, j) = distinctList(1, j) & ", " & i + 1
'k = k + 1
Exit For
End If
If j = UBound(distinctList, 2) Then
ReDim Preserve distinctList(0 To 1, 1 To UBound(distinctList, 2) + 1)
distinctList(0, j) = arr(i)
distinctList(1, j) = distinctList(UBound(distinctList, 2), 1) & ", " & i + 1
Exit For
End If
Next j
End If
Next i
Debug.Print distinctList(0, 0) & " => " & distinctList(1, 0)
'distinctValues = distinctList
End Function
It's because you can't change the lower bound of the second dimension, you need to keep it the same..
You declare ReDim distinctList(0 To 1, 0 To j) at the top
when you redim, you need to keep lower bound of the second dimension at 0
ReDim Preserve distinctList(0 To 1, 0 To UBound(distinctList, 2) + 1)
I think you could implement this general solution to your particular solution if you apply this code to change the nr. of dimensions before you add the/a new category.
Option Explicit
Public Sub redimarray()
'This sub redimensions an array as an array of arrays, so to acces the k'th element in the n-th dimension you need to type: my_array(n)(k)
'and you can still simply redefine the array dimensions by:
'my_array =FlexArray("lower_bound_n-th_dim,lower_bound_n-th_dim,_n+1-th_dim,upper_bound_n-th_dim,_n+1-th_dim) = e.g.: FlexArray("2,3,9,11")
'if you then want to have conventional array element conventional_array(3,4) you can copy the entire my_array into a 1 dimensional array where
' the array elements are added like a (nr-of_elements_per_dimension)-base numbering system. once they have been manipulated, you can store them back into
'nr of elements per dimension:
'dim 0 = 4, 0-3
'dim 1 = 3, 4-6
'dim 2 = 8, 1-8
'nr of elements in 1dim array = 4*3*8 = 96
'(0)(4)(1)
'(0)(4)(2)
'...
'(0)(4)(8)
'(0)(5)(1)
'so working_array(3,5,2) = (3-0)*nr_elem(dim 1)*nr_elem(dim 2)+(5-4)*nr_elem(dim 2)+(2-1)
'dim 0 = nr_elements(0), start_element(0)-end_element(0)
'dim 1 = nr_elements(1), start_element(1)-end_element(1)
'dim 2 = nr_elements(2), start_element(2)-end_element(2)
'so working_array(3,5,2) = (end_element(0)-start_element(0))*nr_elements(1)*nr_elements(2)+(end_element(1)-start_element(1))*nr_elements(2)+'so working_array(3,5,2) = (end_element(0)-start_element(0))*nr_elements(1)*nr_elements(2)+(end_element(2)-start_element(2))=index in 1 dimensional array.
Dim NewArray() As Variant
NewArray = FlexArray("1,2,3,8,2,9")
'NewArray = FlexibleArray("1,2,3,8,2,9")
MsgBox (NewArray(1)(8))
End Sub
Public Function FlexArray(strDimensions As String) As Variant
Dim arrTemp As Variant
Dim varTemp As Variant
Dim varDim As Variant
Dim intNumDim As Integer
Dim iDim As Integer
Dim iArr As Integer
varDim = Split(strDimensions, ",")
intNumDim = (UBound(varDim) + 1) / 2
' Setup redimensioned source array
ReDim arrTemp(intNumDim)
iArr = 0
For iDim = LBound(varDim) To UBound(varDim) Step 2
ReDim varTemp(varDim(iDim) To varDim(iDim + 1))
arrTemp(iArr) = varTemp
iArr = iArr + 1
Next iDim
FlexArray = arrTemp
End Function
Related
I am trying to figure out a loop logic to get all possible permutations where I add a set value to each item in a set array iLoop number of times. I'm gonna try my best to explain what I am looking for.
I have a set value "StrokeValue" and a set array "DistanceMatesArray"
Dim StrokeValue as single
Dim DistanceMatesArray as variant
StrokeValue = 300
DistanceMatesArray = Array(300, 300, 300, 300)
Now I need to loop through each possible result where I add StrokeValue to each Item which in the first loop would result in possible DistanceMatesArrays:
The tricky part is when I want to add StrokeValue more than once and get every outcome where I added StrokeValue iLoop number of time "AllowedActions" resulting in a list such as:
I kind of suspect that I need a 2D array to store all the results from previous loop., that's why in the example the rows are coloured to indicate which one row was taken as a starting point to add the StrokeValue once
What I got so far looks like this:
Public StrokeValue As Single
Public DistanceMatesArray As Variant
Public iError As Long
Public NumberOfCombinations As Long
Public x As Long
Public y As Long
Public i As Long
Option Explicit
Sub Test()
'Declare variables
Dim PreviousLoopResultsArray As Variant
Dim NextLoopResultsArray As Variant
Dim iresults As Long
Dim iLoop As Long
Dim iPreviousResult As Long
'Set variables
StrokeValue = 300
'Array
DistanceMatesArray = Array(300, 300, 300, 300)
ReDim NextLoopResultsArray(0, UBound(DistanceMatesArray))
For i = LBound(DistanceMatesArray) To UBound(DistanceMatesArray)
NextLoopResultsArray(0, i) = DistanceMatesArray(i)
Next i
'------------------------------------------------------
'Loop
Do While iError = NumberOfCombinations
'Try DistanceMatesArray
For i = 0 To iresults
For x = 0 To UBound(DistanceMatesArray) 'Loop horizontally
DistanceMatesArray(x) = NextLoopResultsArray(i, x)
Next x
Debug.Print Join(DistanceMatesArray)
'TRY HERE
Next i
'Array
PreviousLoopResultsArray = NextLoopResultsArray
'Array
If iLoop <> 0 Then
For x = 0 To UBound(DistanceMatesArray) 'Loop horizontally
DistanceMatesArray(x) = PreviousLoopResultsArray(iPreviousResult, x)
Next x
End If
'Set variables
iLoop = iLoop + 1
iPreviousResult = 1
iresults = ((UBound(DistanceMatesArray) + 1) ^ iLoop) - 1
ReDim NextLoopResultsArray(iresults, UBound(DistanceMatesArray))
'Populate NextLoopResultsArray
For y = 0 To iresults 'Loop vertically
If y Mod (UBound(DistanceMatesArray) + 1) = 0 And y <> iresults And y <> 0 Then
For x = 0 To UBound(DistanceMatesArray) 'Loop horizontally
DistanceMatesArray(x) = PreviousLoopResultsArray(iPreviousResult, x)
Next x
iPreviousResult = iPreviousResult + 1
End If
For x = 0 To UBound(DistanceMatesArray) 'Loop horizontally
NextLoopResultsArray(y, x) = DistanceMatesArray(x)
With ThisWorkbook.Worksheets(1).Cells(y + 1, x + 1)
.Value = NextLoopResultsArray(y, x)
End With
Next x
Next y
'Modify NextLoopResultsArray
x = 0
For y = 0 To iresults 'Loop vertically
NextLoopResultsArray(y, x) = NextLoopResultsArray(y, x) + StrokeValue
With ThisWorkbook.Worksheets(1).Cells(y + 1, x + 1)
.Value = NextLoopResultsArray(y, x)
.Interior.Color = vbYellow
End With
If x + 1 > UBound(DistanceMatesArray) Then
x = 0
Else
x = x + 1
End If
Next y
'Set variables
iPreviousResult = 0
'Excel reset
For i = 1 To (UBound(DistanceMatesArray) + 1)
Columns(i).Clear
Next i
Loop
End Sub
At the end of the loop I am expecting to have each one row as DistanceMatesArray i.e. one of them would now be
DistanceMatesArray = array(300,600,600,300)
Where it added StrokeValue twice.
Would someone, please, help me figure out a shorter and simpler logic behind this?
EDIT:
Results expected after running it up to 3 loops looks like this:
And without duplicate outcomes
Continuing to try and figure out the logic of it, maybe now someone get's a betetr idea for what I am lookign for and can help
No need to mention that it's an infinite loop - I know that and That's the point, it needs to go on untill I validate the right array in which case iError <> NumberOfCombinations.
Been able to learn more about arrays, so I consider this a big win.
The code took in account the duplicates but for now your iterations are hardset (could easily ask how many iterations with an inputbox), not in the endless loop you had set up, hope that rework won't be too much.
Some variables are reworked, I tried to keep most of your original ones though.
Public StrokeValue As Single
Public DistanceMatesArray As Variant
Public iError As Long
Public iTerations As Long
Public i As Long
Public j As Long
Public k As Long
Option Explicit
Sub TestArrayfill()
Dim pArray As Variant, nArray As Variant, cArray As Variant 'pArray = previous array, nArray = next array, cArray = check array
Dim iresults As Long, iLoop As Long, nb As Long, actB As Long, addCounter As Long, Lastrow As Long
'Set variables
StrokeValue = 300
addCounter = 1
iTerations = 4
'Array
DistanceMatesArray = Array(300, 300, 300, 300)
nb = UBound(DistanceMatesArray) + 1
ReDim Preserve DistanceMatesArray(1 To nb)
cArray = DistanceMatesArray
ReDim pArray(1 To nb, 1 To nb)
For i = 1 To nb
pArray(1, i) = DistanceMatesArray(i)
Next i
actB = nb
For iLoop = 1 To iTerations 'I can't figure out the limitations with permutations so we'll just bruteforce it with nb*actB (maximum possibilities)
ReDim nArray(1 To nb * actB, 1 To nb) '(re)setting nArray
If iLoop = 1 Then actB = 1 'workaround to have pArray as a 2D-array
For i = 1 To actB 'loop through every row in pArray except for when iLoop = 1
For j = 1 To nb 'loop through every cell in pArray(i)
For k = 1 To nb 'setting the extra StrokeValue
If j = k Then
cArray(k) = pArray(i, k) + StrokeValue
Else
cArray(k) = pArray(i, k)
End If
Next k
If Not arrElemInArray(cArray, nArray) Then
For k = 1 To nb
nArray(addCounter, k) = cArray(k) 'add the "row" to our nArray
Next k
addCounter = addCounter + 1
End If
Next j
Next i
actB = addCounter - 1
ReDim pArray(1 To actB, 1 To nb) 'ReDim is possible on both dimensions, Redim Preserve is not so we use this to our advantage
For i = 1 To actB 'another loop is necessary however
For j = 1 To nb
pArray(i, j) = nArray(i, j)
Next j
Next i
' nArray = Application.Transpose(nArray)
' ReDim Preserve nArray(1 To nb, 1 To actB)
' nArray = Application.Transpose(nArray)
' pArray = Application.Transpose(pArray)
' ReDim pArray(1 To UBound(nArray, 2), UBound(nArray, 1))
' pArray = Application.Transpose(pArray)
' pArray = nArray
addCounter = 1
Lastrow = Range("A" & Rows.Count).End(xlUp).Row
If Lastrow = 1 Then
Cells(Lastrow, 1).Value = "Loop" & iLoop
Else
Cells(Lastrow + 1, 1).Value = "Loop " & iLoop
Lastrow = Lastrow + 1
End If
Cells(Lastrow + 1, 1).Resize(UBound(nArray, 1), UBound(nArray, 2)) = nArray
Next iLoop
End Sub
Function arrElemInArray(arr As Variant, arrX As Variant) As Boolean 'this is from one of your previous questions btw, just a bit modified to fit our needs
Dim i As Long, j As Long, boolFound As Boolean, mtch
If Not IsArray(arrX) Then
For j = LBound(arr) To UBound(arr)
If arr(j) = arrX Then arrElemInArray = True: Exit For
Next j
Exit Function
End If
For i = LBound(arrX) To UBound(arrX)
boolFound = True 'True at beginning so if any cells deviates from the corresponding check, it gets set to False, ergo it doesn't exist yet.
For j = LBound(arr) To UBound(arr)
If arr(j) <> arrX(i, j) Then
boolFound = False
End If
Next j
If boolFound Then arrElemInArray = True: Exit Function
Next i
arrElemInArray = False
End Function
Hope it's all clear and works for you :)
I understood your logic for the first table
but for the following ones I find it difficult to understand what you want especially in relation to the capture that you put in your message
for the first
Sub testing()
Dim StrokeValue As Single
Dim DistanceMatesArray As Variant
Dim i As Long 'variable row iteration
Dim c As Long 'variable column itération
Dim Table As Variant 'variable variant no dimention in the first
StrokeValue = 300
DistanceMatesArray = Array(300, 300, 300, 300) 'is an array in base 0
nb = UBound(DistanceMatesArray) + 1 'convert a ubound of DistanceMatesArray in count (in base 1)
ReDim Table(1 To nb, 1 To nb) 'table dimensioning (variant) in base 1
'loop for row
For i = 1 To UBound(Table) 'start at index 1
'loop for column
For c = 1 To UBound(Table, 2) 'start at index 1
'if index row and index column then item has multipled by (2)
If c <> i Then Table(i, c) = StrokeValue Else Table(i, c) = StrokeValue + StrokeValue
Next c
Next i
'just for see on sheet
Cells.Resize(UBound(Table), UBound(Table)) = Table
End Sub
I'd like to go through list in Excel and assign the values to dictionary. The the dictionary will be put into list. This will happen until the cells in the column are blank. As a result of entire function, the array of dictionaries will be returned.
Function CreateArrayofDicts()
Dim catlist As Variant
Dim catparams() As Variant
Dim ChartParamsDict As Dictionary
Dim k As Long
catlist = ArrayProblemsCat()
i = 1
Do Until IsEmpty(Cells(i, 1))
Set ChartParamsDict = New Scripting.Dictionary
For j = 0 To UBound(catlist)
Debug.Print Cells(i, 1)
If Cells(i, 1) = catlist(j) Then
Debug.Print 5
ChartParamsDict.Add Key:="Cells(1,2)", Item:=Cells(i, 2)
ChartParamsDict.Add Key:="Cells(1,3)", Item:=Cells(i, 3)
ChartParamsDict.Add Key:="Cells(1,4)", Item:=Cells(i, 4)
ReDim Preserve catparams(k)
catparams(k) = ChartParamsDict ' issues is here
k = k + 1
Debug.Print ChartParamsDict
End If
Next j
i = i + 1
Loop
CreateArrayofDicts = catparams
End Function
Your are missing Set on the problem line.
Set catparams(k) = ChartParamsDict
I need to find out a way to output the result of all combinations of the numbers into rows ( best if could be in a single row)
I have 8 digits {1,2,3,4,5,6,7,8} the typical output for the combination is i;j (i, j are numbers from the set and i< j) if pick up two. To generate result is simple:
Dim Myarray_2 As String
Dim sht as Worksheet
set sht = Sheet1
Myarray_2 = "" ' pick up 2 out of 8
For j = 2 To 8
For i = 1 To j - 1
sht.Cells(i + 1, j + 1) = Str(MyArray(i)) + ";" + Str(MyArray(j))
Myarray_2 = Myarray_2 + Str(MyArray(i)) + ";" + Str(MyArray(j)) + "|"
Next i
Next j
This is an example for pick up 2, I already have it output to rows of a worksheet.
I also have solution for picking up 3, now my questions is for the rest of the cases, how to get the out put?
Here is the solution for picking up 3:
Dim Myarray_3 As String
Myarray_3 = "" ' 3 out of 8
k = 3
Do While k >= 3 And k <= 8
'inner loop through i j
For j = 2 To k - 1
For i = 1 To j - 1
sht.Cells(i + 11, j - 1 + m) = Str(MyArray(i)) + ";" + Str(MyArray(j)) + ";" + Str(MyArray(k))
Myarray_3 = Myarray_3 + Str(MyArray(i)) + ";" + Str(MyArray(j)) + ";" + Str(MyArray(k)) + "|"
Next i
Next j
k = k + 1
m = m + 7
Loop
By the way the MyArray(i) is initialized as Myarray(i) = i
I found some code that I got from another good programmer, I changed the code to fit to your problem. If you have N as the number of members of your set/array, then you will have (2^N)-1 combinations, however you can filter them using your own conditions. Note that in your problem, the order of the members would be important when it comes to filtration using your condition.
The code will first generate ALL OF THE COMBINATIONS and then apply the conditions. Array Result would be the main output so its size will be always (2^N)-1. Array Result-filtered will be what you want.
Note that if you have the numbers sorted from left to right, arrays Result and Result_filtered will be the same.
You can print the out put with any format you like into any sheet.
This method uses bitwise calculation to get the combinations:
if N=2, then number of comnibations would be (2^2)-1=3
we always exclude 0 'in binary of course
{A,B} -> { [00],[01],[10],[11] } ->{ ignore, [B],[A],[AB]}
I hope this helps! if it did, please hit the checkmark to this anwer
Run Sub Test:
Sub Test()
Dim bCondSatisfied As Boolean
Dim InxComb As Integer
Dim InxResult As Integer
Dim count As Integer
Dim i As Integer
Dim j As Integer
Dim arr() As String
Dim TestData() As Variant
Dim Result() As Variant
Dim Result_filtered() As Variant
TestData = Array(1, 3, 2, 4)
Call GenerateCombinations(TestData, Result)
'Now you have all the possible combinations, you can apply custom conditions
'(e.g. any number on the left side of another number should be smaller, practically this is satisfied with the
' given test array, but if the numbers are scrambled it will fix the problem)
ReDim Result_filtered(0 To 0)
Result_filtered(0) = "No Combination Matched the Condition" 'default for the case there is no result matched
count = 0
For i = 0 To UBound(Result)
arr() = Result(i)
bCondSatisfied = True
If UBound(arr) > 0 Then 'if there is more than one number in the array, compare the adjacent numbers
For j = 0 To UBound(arr) - 1
If arr(j) > arr(j + 1) Then
bCondSatisfied = False
Exit For
End If
Next j
End If
'Store the array in the filtered array if it passed the test
If bCondSatisfied = True Then
ReDim Preserve Result_filtered(count)
Result_filtered(count) = arr
count = count + 1
End If
Next i
'Print Result
For InxResult = 0 To UBound(Result)
Debug.Print Right(" " & InxResult + 1, 3) & " ";
For InxComb = 0 To UBound(Result(InxResult))
Debug.Print "[" & Result(InxResult)(InxComb) & "] ";
Next
Debug.Print
Next
Debug.Print "-----------------" 'separate two results
'Print Result_filtered
For InxResult = 0 To UBound(Result_filtered)
Debug.Print Right(" " & InxResult + 1, 3) & " ";
For InxComb = 0 To UBound(Result_filtered(InxResult))
Debug.Print "[" & Result_filtered(InxResult)(InxComb) & "] ";
Next
Debug.Print
Next
End Sub
Sub GenerateCombinations(ByRef AllFields() As Variant, _
ByRef Result() As Variant)
Dim InxResultCrnt As Integer
Dim InxField As Integer
Dim InxResult As Integer
Dim i As Integer
Dim NumFields As Integer
Dim Powers() As Integer
Dim ResultCrnt() As String
NumFields = UBound(AllFields) - LBound(AllFields) + 1
ReDim Result(0 To 2 ^ NumFields - 2) ' one entry per combination
ReDim Powers(0 To NumFields - 1) ' one entry per field name
' Generate powers used for extracting bits from InxResult
For InxField = 0 To NumFields - 1
Powers(InxField) = 2 ^ InxField
Next
For InxResult = 0 To 2 ^ NumFields - 2
' Size ResultCrnt to the max number of fields per combination
' Build this loop's combination in ResultCrnt
ReDim ResultCrnt(0 To NumFields - 1)
InxResultCrnt = -1
For InxField = 0 To NumFields - 1
If ((InxResult + 1) And Powers(InxField)) <> 0 Then
' This field required in this combination
InxResultCrnt = InxResultCrnt + 1
ResultCrnt(InxResultCrnt) = AllFields(InxField)
End If
Next
' Discard unused trailing entries
ReDim Preserve ResultCrnt(0 To InxResultCrnt)
' Store this loop's combination in return array
Result(InxResult) = ResultCrnt
Next
End Sub
I want to combine arrays in my program. Take those as an example:
a = {1,2,3,4,5}
b = {6,7,8,9,10}
This should produce an array containing first element of first array with all elements of second array except first element, which is {1,7,8,9,10}. This should continue for all possible combinations, producing these output arrays:
{1,7,8,9,10} {6,2,8,9,10} {6,7,3,9,10} {6,7,8,4,10} {6,7,8,9,5}...
For 2,3,4 elements of first array with second array
{1,2,8,9,10} {6,2,3,9,10} {6,7,3,4,10} {6,7,8,4,5} {1,7,8,9,5}...
{1,7,3,9,10} {6,2,8,4,10} {6,7,3,9,5} {1,7,8,4,10}.....
and vice versa for second array.
For the first combination I've tried:
For I = 0 To 4
'first array loop
For J = 0 To 4
'second array loop
If I <> J Then
arr(J) = arr2(J)
Else
arr(J)=arr1(J)
End If
Next
Next
This will give you every combination possible:
Function fifth(ParamArray arr() As Variant) As Variant()
Dim temp() As Variant
Dim i As Long
Dim j As Long
Dim t As Long
For i = LBound(arr) + 1 To UBound(arr)
If UBound(arr(LBound(arr))) <> UBound(arr(i)) Then
MsgBox "Arrays not same size"
Exit Function
End If
Next i
ReDim temp(1 To (UBound(arr) + 1) ^ (UBound(arr(LBound(arr))) + 1), LBound(arr(LBound(arr))) To UBound(arr(LBound(arr)))) As Variant
For i = 1 To (UBound(arr) + 1) ^ (UBound(arr(LBound(arr))) + 1)
For j = 1 To (UBound(arr(LBound(arr))) + 1)
t = Int((i Mod ((UBound(arr) + 1) ^ j)) / (((UBound(arr) + 1) ^ j) / (UBound(arr) + 1)))
temp(i, j - 1) = arr(t)(j - 1)
Next j
Next i
fifth = temp
End Function
You would call thus:
Sub ArrCombine()
Dim arr1() As Variant
Dim arr2() As Variant
Dim rsltarr() As Variant
arr1 = Array(1, 2, 3, 4, 5)
arr2 = Array(6, 7, 8, 9, 10)
rsltarr = fifth(arr1, arr2)
ActiveSheet.Range("A1").Resize(UBound(rsltarr, 1), UBound(rsltarr, 2) + 1).Value = rsltarr
End Sub
It will output on the active sheet, this:
This also has the advantage of being dynamic. You can use more than two arrays. The only rule is that they need to have the same number of values.
The only other limit is the number of rows on a worksheet. So (number of arrays) ^ (number of values) cannot exceed 2^20.
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