Two array element combination in vb - vba

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.

Related

Adding a dictionary to array

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

Is there a more efficient way to calculate the power set of an array?

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

Allocating a range to an array in VBA

Really new and self taught so would appreciate any help
Have allocated a range from a spreadsheet to an array but it starts the data in row 1 of the array.
Dim arr As Variant
arr = Range("DATA")
Is there any way of starting in row 0?
Thanks in advance
Range operations are slow, the best is to use a temporary array , and then make a copy to another array while changing the start position.
Indeed array -> array = very fast
Dim arr, arr2 As Variant
arr2 = Range("DATA").value2
redim arr(0 to ubound(arr2)-1, 0 to ubound(arr2,2)-1)
for i= 0 to ubound(arr2)-1
for j= 0 to ubound(arr2,2)-1
arr(i,j)= arr2(i+1,j+1)
next
next
Well, if you are going to clean-up range-derived VBA arrays, why not make them 1-dimensional instead of falsely 2-dimensional in the case that you are dealing with a column range or a row range? The following does that as a default and also uses 0-based as a default, but provides ways to override both defaults:
Function RangeToArray(R As Range, Optional b As Long = 0, Optional collapse As Boolean = True) As Variant
'returns a b-based array of the values in R
'if the Range is 1-dimensional and collapse is true, the array returned is 1-dimensional
Dim i As Long, j As Long, m As Long, n As Long, k As Long
Dim vals As Variant, arr As Variant
m = R.Rows.Count
n = R.Columns.Count
If m = 1 And n = 1 Then 'to catch an edge-case
ReDim vals(1 To 1, 1 To 1)
vals(1, 1) = R.Value
Else
vals = R.Value
End If
If collapse And (m = 1 Or n = 1) Then
k = Application.WorksheetFunction.Max(m, n)
ReDim arr(b To b + k - 1)
For i = 1 To k
If m = 1 Then
arr(b + i - 1) = vals(1, i)
Else
arr(b + i - 1) = vals(i, 1)
End If
Next i
Else
ReDim arr(b To b + m - 1, b To b + n - 1)
For i = 1 To m
For j = 1 To n
arr(b + i - 1, b + j - 1) = vals(i, j)
Next j
Next i
End If
RangeToArray = arr
End Function
It would be used like A = RangeToArray(Range("A1:B3"))

Why my array function does not work?

I tried to write a simple bubble sort function in VBA but it does not work. The code is following
Public Function BubbSort(arr As Variant) As Variant
Dim arrReturn As Variant
arrReturn = Array()
ReDim arrReturn(UBound(arr))
arrReturn = arr.Value
For i = 1 To UBound(arr) - 1
For j = 1 To UBound(arr) - 1
If arrReturn(j) > arrReturn(j + 1) Then
temp = arrReturn(j)
arrReturn(j) = arrReturn(j + 1)
arrReturn(j + 1) = temp
End If
Next j
Next i
arr = arrReturn
End Function
In Excel I tried to select 4x1 range of cells and insert formula $=BubbSort(A1:A4)$ and press Ctrl+Shift+Enter so it works as array function, but it said "Function has an error". Any help please?
If arr is a range then UBound(arr) will throw an error. The way around this is to use the line
arrReturn = arr.Value
instead of just
arrReturn = arr
and then to use Ubound(arrReturn)
Also -- arrReturn would be a 2-d array rather than a 1-d array. All references to arrReturn should look like e.g. arrReturn(j,1)
Finally -- you aren't returning anything (which is assigning to the function name in VBA).
The following code seems to work (if Bubble sort can ever be described as "working"):
Public Function BubbSort(arr As Variant) As Variant
Dim arrReturn As Variant
Dim i As Long, j As Long, temp As Variant
arrReturn = arr.Value
For i = 1 To UBound(arrReturn) - 1
For j = 1 To UBound(arrReturn) - 1
If arrReturn(j, 1) > arrReturn(j + 1, 1) Then
temp = arrReturn(j, 1)
arrReturn(j, 1) = arrReturn(j + 1, 1)
arrReturn(j + 1, 1) = temp
End If
Next j
Next i
BubbSort = arrReturn
End Function
The above will only work when passed a range contained in a column. It is possible to make it more flexible to be able to handle either a column range or a row range or a VBA array.
While John Coleman's code will technically work it is fundamentally flawed. You will notice that the outer loop over i is invariant - the loop value is never used.
Bubblesort is indeed inefficient (at least for long sequences) but not as much as the code enforces.
At the end of the inner loop the biggest element will have propagated to the very end of the sequence. So, there is no need to compare it with any previous elements during the next repetitions of the inner loop. If you shorten the inner loop every time by 1 (in total, by the number of outer loop completions so far, i) you reduce the number of loops by 50%:
Public Function Bubble1(arr As Variant) As Variant
Dim arrReturn As Variant
Dim i As Long, j As Long, temp As Variant
arrReturn = arr.Value
For i = UBound(arrReturn, 1) To 2 Step -1
For j = 1 To i - 1
If arrReturn(j, 1) > arrReturn(j + 1, 1) Then
temp = arrReturn(j, 1)
arrReturn(j, 1) = arrReturn(j + 1, 1)
arrReturn(j + 1, 1) = temp
End If
Next j
Next i
Bubble1 = arrReturn
End Function
While we're at it we can further reduce the effort by observing that if all elements are sorted (that is, no exchanges have happened in the inner loop) we are finished - further loops are redundant. We can implement this with a flag:
Public Function Bubble2(arr As Variant) As Variant
Dim arrReturn As Variant
Dim i As Long, j As Long, temp As Variant
Dim sorted As Boolean
arrReturn = arr.Value
For i = UBound(arrReturn, 1) To 2 Step -1
sorted = True
For j = 1 To i - 1
If arrReturn(j, 1) > arrReturn(j + 1, 1) Then
temp = arrReturn(j, 1)
arrReturn(j, 1) = arrReturn(j + 1, 1)
arrReturn(j + 1, 1) = temp
sorted = False
End If
Next j
If sorted Then Exit For
Next i
Bubble2 = arrReturn
End Function

ReDiming an array in VBA

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