At risk of being of topic, I decided to share some code, Q&A-style. If the general opinion is such that this would be off-topic I'll be happy to delete if need be.
Background:
I've been wondering if it was possible to return a 1D-array from multiplying another 1D-array by either a constant value or a third 1D-array (of the same size) without iteration.
So the process I'm looking for would look like:
Multiply by Constant > Derive {3,6,9} directly from {1,2,3}*3
Multiply by array > Derive {3,8,15} directly from {1,2,3}*{3,4,5}
Sample Code:
I have seen questions regarding this topic, but I've not yet seen an answer that would do this without iteration. The closest I've seen is from #SiddharthRout, on an external forum.
But usually one would opt for iteration:
Multiply by constant
Sub Test()
Dim arr1 As Variant: arr1 = Array(1,2,3)
Dim y As Long, x As Long: x = 3 'Our constant
For y = LBound(arr1) To UBound(arr1)
arr1(y) = arr1(y) * x
Next y
End Sub
Multiply by array
Sub Test()
Dim arr1 As Variant: arr1 = Array(1, 2, 3)
Dim arr2 As Variant: arr2 = Array(3, 4, 5)
Dim y As Long
For y = LBound(arr1) To UBound(arr1)
arr1(y) = arr1(y) * arr2(y)
Next y
End Sub
Question:
How could you retrieve a 1D-array from multiplying another 1D-array by any constant or another (equally sized) 1D-array without iteration?
As of what I found was that the key to the answer would lay in MMULT, returning an array from multiplying rows*columns.
Multiply 1D-Array by Constant
Sub Multiply_1D_byConstant()
Dim arr1 As Variant: arr1 = Array(1, 4, 3, 5, 10, 15, 13, 11, 6, 9)
With Application
Dim x As Long: x = 3 'Our constant
Dim y As Long: y = UBound(arr1) + 1
Dim arr2 As Variant: arr2 = .Evaluate("TRANSPOSE(ROW(" & x + 1 & ":" & x + y + 1 & ")-ROW(1:" & y + 1 & "))")
Dim arr3 As Variant: arr3 = .Evaluate("TRANSPOSE(ROW(1:" & y & "))")
Dim arr4 As Variant: arr4 = .Index(.MMult(.Transpose(arr1), arr2), arr3, 1)
End With
End Sub
Here, .Evaluate will quickly return a 1D-array n times our constant, n being Ubound(arr1)+1. In the above case: {3,3,3,3,3,3,3,3,3,3}
We than .Transpose arr1 within our .MMult(.Transpose(arr1), arr2) which will return a 2D-array. Because we would need to iterate that, we rather cut into the array to extract a 1D-array by .Index. The result of the above would be:
{3, 12, 9, 15, 30, 45, 39, 33, 18, 27}
To visualize how this works: .MMult will return a 2D-array from above example like so:
Then, because we basically give .Index an array like {1,2,3,4,5,6,7,8,9,10}, but in a dynamic way, for rows and just a 1 for the first column, .Index will slice a 1D-array out of this 2D-array:
Multiply 1D-Array by 1D-Array
This would work kind of the same. Let's imagine the below:
Sub Multiply_1D_by1D()
Dim arr1 As Variant: arr1 = Array(1, 4, 3, 5, 10, 15, 13, 11, 6, 9)
Dim arr2 As Variant: arr2 = Array(2, 1, 4, 1, 2, 3, 2, 5, 2, 1)
With Application
Dim y As Long: y = UBound(arr1) + 1
Dim arr3 As Variant: arr3 = .Evaluate("TRANSPOSE(ROW(1:" & y & "))")
Dim arr4 As Variant: arr4 = .Index(.MMult(.Transpose(arr1), arr2), arr3, arr3)
End With
End Sub
This time we don't tell .Index to extract the same, constant, first column from the result of .MMult, but we give it the same array of values as the rows. These values need to be a 1D-array so therefor we use the .Evaluate to return the array dynamically. So the above returns a 1D-array like:
{2, 4, 12, 5, 20, 45, 26, 55, 12, 9}
To visualize how this works: .MMult will return a 2D-array from above example like so:
Then, because we basically give .Index two arrays like {1,2,3,4,5,6,7,8,9,10}, but in a dynamic way, .Index will slice a 1D-array out of this 2D-array:
In this same fashion you can slice out any 1D-array from a 2D-array using .Index as long as you both specify the rows and columns parameter with a valid 1D-array. I hope this will be helpfull to anyone.
Related
I am currently trying to combine 46 arrays in to a single array. I have scoured the internet, to no prevail and am hoping someone here can help. I did find the below page, but I need to be able to look through each element of the new array in a nested for loop, so using the method below doesn't quite get me to my end goal.
Excel vba - combine multiple arrays into one
Basically, I need to combine my set of 46 arrays in such a way that I can then loop through each element using a nested for loop. ie.
Set of arrays:
myArray1 = (1, 2, 3, 4)
myArray2 = (5, 6, 7)
myArray3 = (8, 9)
myArray4 = (10, 11, 12, 13, 14)
.
.
.
myArray46 = (101, 102, 103)
Combine them to form new array:
myNewArray = (1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14... 101, 102, 103)
Loop through in nested for loop to check each element against my main array:
For i = LBound(mainArray) to UBound(mainArray)
For j = LBound(myArray) to UBound(myArray)
If mainArray(i) = myArray(j) Then
'do something
End If
Next j
Next i
Any help and/ or guidance with this is greatly appreciated!
Since you write in your comments that your end goal is to create an array of unique elements, you might be best served using a dictionary, where you can test for uniqueness as you add each element to dictionary. Something like:
Option Explicit
Function uniqueArr(ParamArray myArr() As Variant) As Variant()
Dim dict As Object
Dim V As Variant, W As Variant
Dim I As Long
Set dict = CreateObject("Scripting.Dictionary")
For Each V In myArr 'loop through each myArr
For Each W In V 'loop through the contents of each myArr
If Not dict.exists(W) Then dict.Add W, W
Next W
Next V
uniqueArr = dict.keys
End Function
Sub tester()
Dim myArray1, myArray2, myArray3, myArray4, myArray5
myArray1 = Array(1, 2, 3, 4)
myArray2 = Array(5, 6, 7, 8)
myArray3 = Array(9, 10, 11, 12, 13, 14)
myArray4 = Array(15, 16)
myArray5 = Array(1, 3, 25, 100)
Dim mainArray
mainArray = uniqueArr(myArray1, myArray2, myArray3, myArray4, myArray5)
End Sub
If you run Tester, you will see mainArray contains:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
25
100
Using your data this is how to create one array out of many:
Public Sub TestMe()
Dim myA, myB, myC, myD, myE
myA = Array(1, 2, 3, 4)
myB = Array(5, 6, 7)
myC = Array(8, 9)
myD = Array(10, 11, 12, 13, 14)
myE = Array(101, 102, 103)
Dim myCombine As Variant
Dim myNew() As Variant
Dim myElement As Variant
Dim myArr As Variant
Dim cnt As Long
myCombine = Array(myA, myB, myC, myD, myE)
For Each myArr In myCombine
For Each myElement In myArr
ReDim Preserve myNew(cnt)
myNew(cnt) = myElement
cnt = cnt + 1
Next
Next
For cnt = LBound(myNew) To UBound(myNew)
Debug.Print myNew(cnt)
Next cnt
End Sub
The "building" of the new array is facilitated through ReDim Preserve, which keeps the old values in the array whenver the dimension of the array changes. And if you want to do something with these arrays, you may use 3 nested loops (a bit slow) and have some check:
Dim cnt2 As Long
For cnt = LBound(myNew) To UBound(myNew)
For cnt2 = LBound(myCombine) To UBound(myCombine)
For Each myElement In myCombine(cnt2)
If myElement = myNew(cnt) Then
Debug.Print myElement & vbTab & " from " & vbTab & cnt2
End If
Next myElement
Next cnt2
Next cnt
This is what you get on the immediate window:
1 from 0
2 from 0
3 from 0
4 from 0
5 from 1
6 from 1
7 from 1
8 from 2
9 from 2
10 from 3
11 from 3
12 from 3
13 from 3
14 from 3
101 from 4
102 from 4
103 from 4
Alternate 'brick-by-brick' approach.
Option Explicit
Sub combineArrays()
Dim myArray1 As Variant, myArray2 As Variant, myArray3 As Variant
Dim myArray4 As Variant, myArray46 As Variant
ReDim mainArray(0) As Variant
myArray1 = Array(1, 2, 3, 4)
myArray2 = Array(5, 6, 7)
myArray3 = Array(8, 9)
myArray4 = Array(10, 11, 12, 13, 14)
'...
myArray46 = Array(101, 102, 103)
mainArray = buildMainArray(myArray1, mainArray)
mainArray = buildMainArray(myArray2, mainArray)
mainArray = buildMainArray(myArray3, mainArray)
mainArray = buildMainArray(myArray4, mainArray)
mainArray = buildMainArray(myArray46, mainArray)
ReDim Preserve mainArray(UBound(mainArray) - 1)
Debug.Print Join(mainArray, ",")
End Sub
Function buildMainArray(arr As Variant, marr As Variant)
Dim i As Long
For i = LBound(arr) To UBound(arr)
marr(UBound(marr)) = arr(i)
ReDim Preserve marr(UBound(marr) + 1)
Next i
buildMainArray = marr
End Function
The issue with using Redim Preserve to combine arrays is it can be an expensive operation, since you're basically re-creating the array everytime it's called. Since you have 46 arrays you're combining, you may very well be waiting a while.
Instead, you can loop over the arrays to figure out the total number of elements you need, dimension out your master array, then loop over the arrays again to do the actual assignment/merging. Something like this:
' encapsulates code to determine length of an individual array
' note that because arrays can have different LBounds in VBA, we can't simply use
' Ubound to determine array length
Public Function GetArrayLength(anArray As Variant) As Integer
If Not IsArray(anArray) Then
GetArrayLength = -1
Else
GetArrayLength = UBound(anArray) - LBound(anArray) + 1
End If
End Function
Public Function CombineArrays(ParamArray arraysToMerge() As Variant) As Variant
' index for looping over the arraysToMerge array of arrays,
' and then each item in each array
Dim i As Integer, j As Integer
' variable to store where we are in the combined array
Dim combinedArrayIndex As Integer
' variable to hold the number of elements in the final combined array
Dim CombinedArrayLength As Integer
' we don't initialize the array with an array-length until later,
' when we know how long it needs to be.
Dim combinedArray() As Variant
' we have to loop over the arrays twice:
' First, to figure out the total number of elements in the combined array
' second, to actually assign the values
' otherwise, we'd be using Redim Preserve, which can get quite expensive
' because we're creating a new array everytime we use it.
CombinedArrayLength = 0
For i = LBound(arraysToMerge) To UBound(arraysToMerge)
CombinedArrayLength = CombinedArrayLength + GetArrayLength(arraysToMerge(i))
Next i
' now that we know how long the combined array has to be,
' we can properly initialize it.
' you can also use the commented code instead, if you prefer 1-based arrays.
ReDim combinedArray(0 To CombinedArrayLength - 1)
' Redim combinedArray(1 to CombinedArrayLength)
' now that the combinedarray is set up to store all the values in the arrays,
' we can begin actual assignment
combinedArrayIndex = LBound(combinedArray)
For i = LBound(arraysToMerge) To UBound(arraysToMerge)
For j = LBound(arraysToMerge(i)) To UBound(arraysToMerge(i))
combinedArray(combinedArrayIndex) = arraysToMerge(i)(j)
combinedArrayIndex = combinedArrayIndex + 1
Next j
Next i
' assign the function to the master array we've been using
CombineArrays = combinedArray
End Function
To use this function, you'd do something like the following:
Public Sub TestArrayMerge()
Dim myArray1() As Variant
Dim myArray2() As Variant
Dim myArray3() As Variant
Dim myArray4() As Variant
Dim combinedArray As Variant
myArray1 = Array(1, 2, 3, 4)
myArray2 = Array(5, 6, 7)
myArray3 = Array(8, 9)
myArray4 = Array(10, 11, 12, 13, 14)
combinedArray = CombineArrays(myArray1, myArray2, myArray3, myArray4)
If IsArray(combinedArray) Then
Debug.Print Join(combinedArray, ",")
End If
End Sub
Regarding your last bit, that you're using an inner loop to combine the values in your final combined array: Your inner loop doesn't need to start at LBound(myArray). For any value of i, you've already compared it to the elements before it (e.g., when i = 2, it's already been compared to the first element). So you really just need:
For i = LBound(combinedArray) To UBound(combinedArray) - 1
For j = i + 1 To UBound(combinedArray)
' do whatever you need
Next j
Next i
Perhaps this ...
'To determine if a multi-dimension array is allocated (or empty)
'Works for any-dimension arrays, even one-dimension arrays
Public Function isArrayAllocated(ByVal aArray As Variant) As Boolean
On Error Resume Next
isArrayAllocated = IsArray(aArray) And Not IsError(LBound(aArray, 1)) And LBound(aArray, 1) <= UBound(aArray, 1)
Err.Clear: On Error GoTo 0
End Function
'To determine the number of items within any-dimension array
'Returns 0 when array is empty, and -1 if there is an error
Public Function itemsInArray(ByVal aArray As Variant) As Long
Dim item As Variant, UBoundCount As Long
UBoundCount = -1
If IsArray(aArray) Then
UBoundCount = 0
If isArrayAllocated(aArray) Then
For Each item In aArray
UBoundCount = UBoundCount + 1
Next item
End If
End If
itemsInArray = UBoundCount
End Function
'To determine the number of dimensions of an array
'Returns -1 if there is an error
Public Function nbrDimensions(ByVal aArray As Variant) As Long
Dim x As Long, tmpVal As Long
If Not IsArray(aArray) Then
nbrDimensions = -1
Exit Function
End If
On Error GoTo finalDimension
For x = 1 To 65536 'Maximum number of dimensions (size limit) for an array that will work with worksheets under Excel VBA
tmpVal = LBound(aArray, x)
Next x
finalDimension:
nbrDimensions = x - 1
Err.Clear: On Error GoTo 0
End Function
'****************************************************************************************************
' To merge an indefinite number of one-dimension arrays together into a single one-dimension array
' Usage: mergeOneDimArrays(arr1, arr2, arr3, ...)
' Returns an empty array if there is an error
' Option Base 0
'****************************************************************************************************
Public Function mergeOneDimArrays(ParamArray infArrays() As Variant) As Variant
Dim x As Long, y As Long, UBoundCount As Long, newUBoundCount As Long
Dim tmpArr As Variant, allArraysOK As Boolean
UBoundCount = 0
allArraysOK = True
For x = LBound(infArrays) To UBound(infArrays)
If Not IsArray(infArrays(x)) Or Not nbrDimensions(infArrays(x)) = 1 Then
allArraysOK = False
Exit For
End If
UBoundCount = UBoundCount + itemsInArray(infArrays(x))
Next x
If allArraysOK Then
ReDim tmpArr(0 To UBoundCount - 1)
UBoundCount = 0
For x = LBound(infArrays) To UBound(infArrays)
For y = LBound(infArrays(x)) To UBound(infArrays(x))
tmpArr(UBoundCount) = infArrays(x)(y)
UBoundCount = UBoundCount + 1
Next y
Next x
newUBoundCount = itemsInArray(tmpArr)
If newUBoundCount = UBoundCount Then
mergeOneDimArrays = tmpArr
Else
mergeOneDimArrays = Array()
End If
Erase tmpArr
Else
mergeOneDimArrays = Array()
End If
End Function
If you are working with one-dimensional arrays you could use a collection instead. It is much better at handling dynamic sizing.
You can declare a collection and then add each of the elements in the arrays to it. Then you will have one large list with all of the values.
Dim coll As New Collection
coll.Add MyArray(j)
Here is a good to collections introduction:
https://excelmacromastery.com/excel-vba-collections/
I have an integer array of values and want to find a simple way of calculating its cumulative sum (S = Data(1) + Data(2) + ... + Data(x)).
I already created this function:
Function CumulativeSum(Data() As Integer, k As Integer) As Integer
For entry = 1 To k
CumulativeSum = CumulativeSum + Data(entry)
Next entry
End Function
and it's working fine. However, I wonder if there's a better way of doing it (mainly without the use of any extra function and essentially using only excel functions like Application.Sum). I made a small search on the web but didn't find anything on this basis.
I know I'm not asking to correct any code and I'm just asking for an alternative which is not the real purpose of this forum. However, I also suspect that the answer could be simple, so... If anyone care to help me I'll appreciate very, very much! If you find an answer to a similar question, please share the link with me and I'll remove this one.
I'm very sorry for probably my lack of explicitly on my demand: I simply want to find a simple way of calculating the cumulative sum using simple functions on the macro routine itself, WITHOUT using the CumulativeSum function I created or any other function created by the user.
If you want to achieve a cumulative array array like Array(a,a+b,a+b+c) from Array(a,b,c), then this is the function to achieve it, if you want to pass start and end parameters:
Public Sub TestMe()
Dim outputArray As Variant
Dim inputArray As Variant
Dim counter As Long
inputArray = Array(1, 2, 4, 8, 16, 32, 64)
outputArray = generateCumulativeArray(inputArray, 1, 4)
For counter = LBound(outputArray) To UBound(outputArray)
Debug.Print outputArray(counter)
Next counter
outputArray = generateCumulativeArray(inputArray, toValue:=4)
For counter = LBound(outputArray) To UBound(outputArray)
Debug.Print outputArray(counter)
Next counter
End Sub
Public Function generateCumulativeArray(dataInput As Variant, _
Optional fromValue As Long = 0, _
Optional toValue As Long = 0) As Variant
Dim i As Long
Dim dataReturn As Variant
ReDim dataReturn(0)
dataReturn(0) = dataInput(fromValue)
For i = 1 To toValue - fromValue
ReDim Preserve dataReturn(i)
dataReturn(i) = dataReturn(i - 1) + dataInput(fromValue + i)
Next i
generateCumulativeArray = dataReturn
End Function
Concerning just summing an array, this is the way to do it:
You can use the WorksheetFunction. and you can pass the array as an argument. Thus, you get all the functions, e.g. Average, Min, Max etc:
Option Explicit
Public Sub TestMe()
Dim k As Variant
k = Array(2, 10, 200)
Debug.Print WorksheetFunction.Sum(k)
Debug.Print WorksheetFunction.Average(k)
End Sub
If you want the sum from a given start to a given end, the easiest way is probably to make a new array and to sum it completely. In Python this is called slicing, in VBA this could be done a bit manually:
Public Sub TestMe()
Dim varArr As Variant
Dim colSample As New Collection
varArr = Array(1, 2, 4, 8, 16, 32, 64)
colSample.Add (1)
colSample.Add (2)
colSample.Add (4)
colSample.Add (8)
Debug.Print WorksheetFunction.Sum(generateArray(varArr, 2, 4))
Debug.Print WorksheetFunction.Sum(generateArray(colSample, 2, 4))
End Sub
Public Function generateArray(data As Variant, _
fromValue As Long, _
toValue As Long) As Variant
Dim i As Long
Dim dataInternal As Variant
Dim size As Long
size = toValue - fromValue
ReDim dataInternal(size)
For i = LBound(dataInternal) To UBound(dataInternal)
dataInternal(i) = data(i + fromValue)
Next i
generateArray = dataInternal
End Function
The idea is that the generateArray function returns a new array. Thus, its complete sum is what you need. It works also with collections, not only with arrays. Be careful, when using collections, they start with index 1, while arrays (usually) start with 0. If you want to use the same indexing for Arrays and Collections, then change the generateArray function to this one:
Public Function generateArray(data As Variant, _
fromValue As Long, _
toValue As Long) As Variant
Dim i As Long
Dim dataInternal As Variant
Dim size As Long
size = toValue - fromValue
ReDim dataInternal(size)
If IsArray(data) Then
For i = LBound(dataInternal) To UBound(dataInternal)
dataInternal(i) = data(i + fromValue)
Next i
Else
For i = LBound(dataInternal) To UBound(dataInternal)
dataInternal(i) = data(i + fromValue + 1)
Next i
End If
generateArray = dataInternal
End Function
Or write Option Base 1 on top and the array will start from 1 (not advised!).
Try this:
Sub test()
Dim arr As Variant
arr = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)
Dim mySum As Long, k As Long
Dim wsf As WorksheetFunction
Set wsf = Application.WorksheetFunction
k = 6
'operative line below
mySum = wsf.Sum(wsf.Index(arr, 1, Evaluate("ROW(1:" & k & ")")))
MsgBox mySum
End Sub
For cumulative sum try the following
Function CumulativeSum(Data() As Integer, k As Integer) As Integer
Dim tempArr
tempArr = Data
ReDim Preserve temp(0 To k - 1)
CumulativeSum = WorksheetFunction.Sum(tempArr)
End Function
EDIT :
Sub Demo()
Dim MyArray
Dim i As Long
MyArray = Array(1, 2, 3, 4, 5, 6, 7, 8, 9)
Debug.Print MyArray(LBound(MyArray))
For i = LBound(MyArray) + 1 To UBound(MyArray)
MyArray(i) = MyArray(i - 1) + MyArray(i)
Debug.Print MyArray(i)
Next i
End Sub
Above code updates array arr from
1, 2, 3, 4, 5, 6, 7, 8, 9
to
1, 3, 6, 10, 15, 21, 28, 36, 45
This function returns an array with the cumulative sum of the original vector.
Function CumuVector(Vec As Variant) As Variant()
Dim element, v() As Variant
Dim i As Integer
lastindexinvec = 0
For Each element In Vec
lastindexinvec = last + 1
Next
ReDim v(lastindexinvec) As Variant
i = 0
For Each element In Vec
If i < last Then
sum = sum + element
v(i) = sum
i = i + 1
End If
Next
CumuVector = v
End Function
I've done some search and tried new codes since last night but haven't yet found the answer I was looking for.
I'm working with multiple arrays but am only looking for duplicates in one array at a time. Having duplicates across different arrays doesn't matter; only duplicates within a single array matters.
Each array has between 5 and 7 elements.
Each element is an integer between 1 and 10.
Some sample arrays can be
Array1 = (5, 6, 10, 4, 2)
Array2 = (1, 1, 9, 2, 5)
Array3 = (6, 3, 3, 3, 6)
Array4 = (1, 2, 3, 3, 3, 3, 2)
etc.
For each array, I would like to know how many duplicates there are. That is,
For Array1, I would like a resulting array of (1) indicating there is no duplicate and each element is unique. DuplicateCount (Array1) = (1).
For Array2, the resulting array should (2, 1) indicating there are 2 duplicates of 1 and the rest of the elemets are unique. DuplicateCount (Array2) = (2, 1).
For Array3, I would like a resulting array of (3, 2) indicating there are 3 duplicates of 3 and 2 duplicates of 6. DuplicateCount (Array3) = (3, 2).
For array 4, I would like a resulting array of (4, 2, 1) as there are 4 duplicates of 3, 2 duplicates of 2, and 1 unique 1. DuplicateCount (Array4) = (4, 2, 1).
I really appreciate all your help.
Thanks.
I think a dictionary might be a good solution for you, because it can store each unique number of array as key and their count as value. If the number exists in the dictionary, then its count will be incremented. Here's my implementation:
Function DuplicateCount(nums As Variant) As Scripting.Dictionary
Dim dict As New Scripting.Dictionary
For Each num In nums
If dict.Exists(num) Then
dict(num) = dict(num) + 1
Else
dict(num) = 1
End If
Next
Set DuplicateCount = dict
End Function
Before using the above code in your application, please ensure that the reference Microsoft Scripting Runtime is enabled (go to Tools -> References and check its box). Now you're ready to go, you can see the full script here:
Sub Main()
Dim array1() As Variant: array1 = Array(5, 6, 10, 4, 2)
Dim array2() As Variant: array2 = Array(1, 1, 9, 2, 5)
Dim array3() As Variant: array3 = Array(6, 3, 3, 3, 6)
Dim array4() As Variant: array4 = Array(1, 2, 3, 3, 3, 3, 2)
Dim result1 As New Scripting.Dictionary
Dim result2 As New Scripting.Dictionary
Dim result3 As New Scripting.Dictionary
Dim result4 As New Scripting.Dictionary
Set result1 = DuplicateCount(array1)
Set result2 = DuplicateCount(array2)
Set result3 = DuplicateCount(array3)
Set result4 = DuplicateCount(array4)
For Each k In result1.Keys()
If result1(k) > 1 Then
'(Nothing)
Debug.Print k & "," & result1(k)
End If
Next
Debug.Print
For Each k In result2.Keys()
If result2(k) > 1 Then
'1,2
Debug.Print k & "," & result2(k)
End If
Next
Debug.Print
For Each k In result3.Keys()
If result3(k) > 1 Then
'6,2
'3,3
Debug.Print k & "," & result3(k)
End If
Next
Debug.Print
For Each k In result4.Keys()
If result4(k) > 1 Then
'2,2
'3,4
Debug.Print k & "," & result4(k)
End If
Next
End Sub
Function DuplicateCount(nums As Variant) As Scripting.Dictionary
Dim dict As New Scripting.Dictionary
For Each num In nums
If dict.Exists(num) Then
dict(num) = dict(num) + 1
Else
dict(num) = 1
End If
Next
'Debug: Enable the below lines to print the key-value pairs
'For Each k In dict.Keys()
' Debug.Print k & "," & dict(k)
'Next
Set DuplicateCount = dict
End Function
Sub tester()
Debug.Print Join(RepCount(Array(5, 6, 10, 4, 2)), ",")
Debug.Print Join(RepCount(Array(1, 2, 3, 3, 3, 3, 2)), ",")
Debug.Print Join(RepCount(Array(6, 3, 3, 3, 6)), ",")
Debug.Print Join(RepCount(Array(6, 6, 3, 3, 3, 6)), ",")
End Sub
Function RepCount(arrIn)
Dim rv(), rv2(), i, m, mp, n
ReDim rv(1 To Application.Max(arrIn))
ReDim rv2(0 To UBound(rv) - 1)
For i = 0 To UBound(arrIn)
rv(arrIn(i)) = rv(arrIn(i)) + 1
Next i
For i = 1 To UBound(rv)
m = Application.Large(rv, i) 'i'th largest rep count
If IsError(m) Then Exit For 'error=no more reps
If m <> mp Then 'different from the previous
rv2(n) = m
n = n + 1
End If
mp = m
Next i
ReDim Preserve rv2(0 To n - 1) 'size array to fit content
RepCount = rv2
End Function
Quick Question on Jagged Arrays. I have a static container array that will not change in size:
Dim StaticArray(1 to 3, 1 to 4, 1 to 12) as variant
I am assigning array values to each index in the static array as follows:
Dim ArrayInput() as Variant
ArrayInput = Array(1,2,3,4,5)
StaticArray(1,1,1) = ArrayInput
After assigning the array of values into StaticArray, I want the flexibility to add one more value to the ArrayInput Variable.
Is there any way to redim preserve the Variant contained in StaticArray(1,1,1)? Something like:
Redim Preserve StaticArray(1 to 3, 1 to 4, 1 to 12)(1 to ubound(?)+1)
Or is the only option to modify the ArrayInput variable and re-read?
Thanks!
I was wondering the same thing!
As you mention, I can only achieve this by creating a temporary array, redimensioning and then reassigning to the original jagged array. Here is my code:
Dim StaticArray(1 To 3, 1 To 4, 1 To 12) As Variant
Dim ArrayInput() As Variant
Dim TempArray() As Variant
ArrayInput = Array(1, 2, 3, 4, 5)
StaticArray(1, 1, 1) = ArrayInput
'Instead of redim, store array temporarily
TempArray = StaticArray(1, 1, 1)
'Redim the temporary
ReDim Preserve TempArray(UBound(TempArray) + 1)
'Asign value
TempArray(UBound(TempArray)) = 6
'Then store again on statick array
StaticArray(1, 1, 1) = TempArray
The Microsoft site suggests the following code should work:
Dim numbers = {{1, 2}, {3, 4}, {5, 6}}
However I get a complile error when I try to use it in an excel VBA module.
The following does work for a 1D array:
A = Array(1, 2, 3, 4, 5)
However I have not managed to find a way of doing the same for a 2D array.
Any ideas?
You can also use a shorthand format leveraging the Evaluate function and a static array. In the code below, varData is set where [] is the shorthand for the Evaluate function and the {...} expression indicates a static array. Each row is delimited with a ; and each field delimited with a ,. It gets you to the same end result as simoco's code, but with a syntax closer to your original question:
Sub ArrayShorthand()
Dim varData As Variant
Dim intCounter1 As Integer
Dim intCounter2 As Integer
' set the array
varData = [{1, 2, 3; 4, 5, 6; 7, 8, 9}]
' test
For intCounter1 = 1 To UBound(varData, 1)
For intCounter2 = 1 To UBound(varData, 2)
Debug.Print varData(intCounter1, intCounter2)
Next intCounter2
Next intCounter1
End Sub
The Microsoft site suggests...
This suggestion is for VB.NET but not VBA.
For VBA you were in the right direction. You can do this:
Dim A as Variant
A = Array(Array(1, 2), Array(3, 4), Array(5, 6))
Alternative via Application.Index()
Extending on Dmitriv Pavliv's use of a jagged array (and as alternative to Robin Mackenzie's short hand approach), you can go a step further by applying Application.Index() on this array of arrays (with identical number of elements each) - note the double zero arguments!:
Sub Get2DimArray()
Dim arr() As Variant
'a) build array of arrays (aka as jagged array)
arr = Array(Array(1, 2, 4), Array(4, 5, 6), Array(7, 8, 9))
'b) make it 2-dimensional
arr = Application.Index(arr, 0, 0)
End Sub
Results in
a 2-dim arr(1 To 3, 1 To 3), where
* Row 1 ~> 1|2|4
* Row 2 ~> 4|5|6
* Row 3 ~> 7|8|9
Related link
Further reading regarding Some pecularities of the Application.Index() function
So here you generate the array without anything on it, just by telling its dimensions.
Dimension is X+1 because 0 counts as a position in the array.
Dim MyArray(X, X) As Integer
Then you fill it by doing for exemple
MyArray (0,0) = 1
MyArray (0,1) = 2
MyArray (1,0) = 3
MyArray (1,1) = 4
...
And so on.
If you want a more convenient way of filling it you can use For Cycles if there is a inherent logic to the numbers you are filling it with.
In case the size is unknown until run time.
Dim nRows As Integer, nCols As Integer
...
Dim yourArray() As Integer
ReDim yourArray(1 to nRows, 1 to nCols) 'One base initialisation
'ReDim yourArray(0 to nRows - 1, 0 to nCols - 1) 'Zero base initialisation
Then you can initialise (or access) the grid as:
yourArray(1, 1) = ... 'set first cell