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
Related
I have 2 arrays that I want to combine into a single array of all possible combinations. I then need to loop through all of the combinations and popular arguments for a function. My arrays are not equal in size, and my attempts so far have resulted in a combined array only having 1 pair of values. This is VBA in PowerPoint, not Excel, if that makes a difference to available syntax.
How can I go from this:
arrayColor = Array("Blue","Green","Red")
arraySize = Array("XS","S","M","L","XL")
To this:
arrayCombo(0,0) = "Blue"
arrayCombo(0,1) = "XS"
arrayCombo(1,0) = "Blue"
arrayCombo(1,1) = "S"
...
arrayCombo(15,0) = "Red"
arrayCombo(15,1) = "XL"
And then use a loop to call each pair of values and populate argument values. This code just to illustrate the concept; it's certainly not legit. Pretty sure I need a nested loop here?
For i = 0 To UBound(arrayCombo(i))
nextSubToFire(color, size)
Next i
This is what I've got so far, but it only results in a single pair in my combined array. It's based on this question, but I think I'm either missing something or the sole answer there isn't quite correct. I've looked at other similar questions, but can't wrap my head around doing this with an array compiled in the code rather than the other examples all tailored to Excel.
Option Explicit
Dim arrayColorSize, arrayCombo
Sub CoreRoutine()
Dim arrayColor, arraySize
arrayColor = Array("Blue","Green","Red")
arraySize = Array("XS","S","M","L","XL")
arrayColorSize = Array(arrayColor, arraySize)
arrayCombo = Array(0, 0)
DoCombinations (0)
Dim a As Integer
Dim b As Integer
'For loop comes next once I figure out how to populate the full arrayCombo
End Sub
Sub DoCombinations(ia)
Dim i
For i = 0 To UBound(arrayColorSize(ia)) ' for each item
arrayCombo(ia) = arrayColorSize(ia)(i) ' add this item
If ia = UBound(arrayColorSize) Then
Else
DoCombinations (ia + 1)
End If
Next i
End Sub
Using the Locals window, I see arrayCombo exists, but it only has 1 pair of values in it, which is the last set of pairing options. I see that arrayColorSize has the 2 array sets as I'd expect, so I suspect the DoCombinations sub is missing something.
Any guidance much appreciated!
One way of doing this is to combine the two 1D arrays into a 2D array with 2 columns (as in your example):
Private Function Combine1DArrays(ByRef arr1 As Variant, ByRef arr2 As Variant) As Variant
If GetArrayDimsCount(arr1) <> 1 Or GetArrayDimsCount(arr2) <> 1 Then
Err.Raise 5, "Combine1DArrays", "Expected 1D arrays"
End If
'
Dim count1 As Long: count1 = UBound(arr1) - LBound(arr1) + 1
Dim count2 As Long: count2 = UBound(arr2) - LBound(arr2) + 1
Dim i As Long, j As Long, r As Long
Dim result() As Variant
'
ReDim result(0 To count1 * count2 - 1, 0 To 1)
r = 0
For i = LBound(arr1) To UBound(arr1)
For j = LBound(arr2) To UBound(arr2)
result(r, 0) = arr1(i)
result(r, 1) = arr2(j)
r = r + 1
Next j
Next i
Combine1DArrays = result
End Function
Public Function GetArrayDimsCount(ByRef arr As Variant) As Long
Const MAX_DIMENSION As Long = 60
Dim dimension As Long
Dim tempBound As Long
'
On Error GoTo FinalDimension
For dimension = 1 To MAX_DIMENSION
tempBound = LBound(arr, dimension)
Next dimension
FinalDimension:
GetArrayDimsCount = dimension - 1
End Function
You can use it like this for example:
Sub CoreRoutine()
Dim arrayColorSize As Variant
Dim i As Long
Dim color As String
Dim size As String
'
arrayColorSize = Combine1DArrays(Array("Blue", "Green", "Red") _
, Array("XS", "S", "M", "L", "XL"))
For i = LBound(arrayColorSize, 1) To UBound(arrayColorSize, 1)
color = arrayColorSize(i, 0)
size = arrayColorSize(i, 1)
NextSubToFire color, size
Next i
End Sub
Sub NextSubToFire(ByVal color As String, ByVal size As String)
Debug.Print color, size
End Sub
I have a variant array with a variety of values.
For example let's say they are the following:
1, 2, 3, 0, 4, 5, 0, 0, 0, 0
I want to take an average of that array, however I want to ignore the zeroes.
My problem is that the "WorksheetFunction.AverageIf()" function can only use ranges.
I have found countless help converting a range into a variant array, but nothing on converting a variant array into a range.
since it is already an array it will be quicker just to loop the array and sum the values and divide by the number of items in the array above 0:
Sub lkjlkj()
Dim arr As Variant
arr = Array(1, 2, 3, 0, 4, 5, 0, 0, 0, 0)
Dim sm As Double
sm = 0#
Dim cnt As Long
cnt = 0
Dim i As Long
For i = LBound(arr) To UBound(arr)
If arr(i) > 0 Then
sm = sm + arr(i)
cnt = cnt + 1
End If
Next i
Dim avg As Double
avg = sm / cnt
Debug.Print avg
End Sub
Average With Exceptions
This one uses a combination of Application.Sum and Application.Match:
Option Explicit
Sub getAvgWithExceptions()
Dim Data As Variant: Data = Array(1, 2, 3, 0, 4, 5, 0, 0, 0, 0)
Dim Exceptions As Variant: Exceptions = Array(0)
Debug.Print getAverage(Data, Exceptions)
End Sub
Function getAverage(Data As Variant, Exceptions As Variant) As Double
Dim DataSum As Double: DataSum = Application.Sum(Data)
Dim DataCount As Long: DataCount = count1D(Data, Exceptions)
getAverage = DataSum / DataCount
End Function
Function count1D(Data As Variant, Exceptions As Variant) As Long
Dim i As Long
For i = LBound(Data) To UBound(Data)
If IsError(Application.Match(Data(i), Exceptions, 0)) Then
count1D = count1D + 1
End If
Next i
End Function
A simple alternative
Via boundary count and negative filtering you could count the non-zero items and divide the array sum by this divisor:
Sub TestAverage()
Dim a: a = Array(1, 2, 3, 0, 4, 5, 0, 0, 0, 0)
dim avg as Double: avg = Application.Sum(a) / (UBound(Filter(a, 0, False)) + 1)
Debug.Print avg
End Sub
Caveat//Edit: Filter gets any partial finding, so searching 0 would also find 10 or 20. A refined function based on counting the items in Application.Match() - c.f. #VBasic2008 's solution - applied on the given array as first argument and Array(0) as 2nd argument gets waterproof results. Hint: Application.Count() omits error values, so you avoid a further loop.
Function AvgWithoutZeros(arr1D As Variant) As Double
With Application
Dim n: n = .Count(arr1D) - .Count(.Match(arr1D, Array(0), 0)) ' number of non-zero items
AvgWithoutZeros = .Sum(arr1D) / n
End With
End Function
Example calls
Sub TestAverageOfArrayValues()
Dim a: a = Array(1, 2, 3, 0, 4, 5, 0, 0, 0, 0)
Debug.Print AvgWithoutZeros(a)
End Sub
Just to demonstrate some array conversions based on a given range (e.g. column A):
Sub HowToConvertRangeTo1DimArray()
With Sheet1 ' Code(Name) of your worksheet
Dim lastRow As Long: lastRow = .Range("A" & .Rows.Count).End(xlUp).row
Dim rng As Range: Set rng = .Range("A2:D" & lastRow) ' start e.g. in row 2
End With
Dim arr2Dim: arr2Dim = rng.Value ' assign data to 2-dim array
Dim arr1Dim: arr1Dim = Application.Transpose(arr2Dim) ' make array "flat"
Debug.Print AvgWithoutZeros(arr1Dim)
End Sub
Ranges are defined within the spreadsheet as the function I was originally trying to use requires the use of values in the spreadsheet. Nobody could figure out a way to use the "AverageIf" function simply because they would have to change the spreadsheet itself, forcing values into areas that may already be populated.
The better solution is to simply build an averaging function with an if-statement within it. My particular problem was to only average values that are not zero.
Here is that code:
Public Function AvgIf(rng As Range)
'Declaring Variables
Dim array1() As Variant
Dim i As Integer
Dim ii As Integer
Dim Xdim As Integer
Dim Ydim As Integer
Dim temp1 As Integer
Dim temp2 As Integer
'In this example, the array is user-defined by the input range
array1 = rng.Value
'Find Array Size
Xdim = UBound(array1, 1)
Ydim = UBound(array1, 2)
'Cycling through every cell of the array
For i = 1 To (Xdim)
For ii = 1 To (Ydim)
'Insert If Statement Here (You can change it to be whatever you want)
If array1(i, ii) > 0 Then
temp1 = temp1 + array1(i, ii)
temp2 = temp2 + 1
End If
Next ii
Next i
'Cheating by doing the last calculation in the output
AvgIf = temp1 / temp2
End Function
That is what you should ideally use instead of forcing data into your spreadsheet.
Alternatively, if your problem is similar to mine (array is just a copy of a range), you can follow the below information:
Since my range was converted into an array, I simply used the original range to solve the issue. (See below for code)
Public Function TempAvg(rng as Range)
Dim i as integer
Dim t1 as Double
Dim t2 as Double
For i = 1 to 20
If rng(i) > 0 Then t1 = t1 + rng(i)
If rng(1) > 0 Then t2 = t2 + 1
Next i
TempAvg = t1 / t2
End Function
That fixed my issues. I apologize to all those posting elegant solutions as I can't seem to get them to work in the scope of my project. I'm sure it's something I've messed up, not their code. Please read the other answers for possibly better solutions.
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 am trying to slice several columns out of my original array "dataset" this does not work and I don't know why, could someone please provide some insight here?
Sub Pooling()
dim dataset()
Dim rows As Long
Dim columns As Long
Dim varTemp()
rows = ShUnicorn.Cells(ShUnicorn.rows.Count, 1).End(xlUp).Row
columns = ShUnicorn.Cells(1, ShUnicorn.columns.Count).End(xlToLeft).Column
dataset = ShUnicorn.Range(ShUnicorn.Cells(1, 1), ShUnicorn.Cells(rows, columns))
varTemp = Application.Index(dataset, 0, Array(5, 6, 11, 12, 17, 18))
For i = 1 To 5
For j = 1 To 5
shSmear.Cells(40 + j, i + 3).Value = varTemp(j, i)
Next j
Next i
End Sub
So this might be an easy one but I just couldn't work my head around it.I am working on VBA.
I have the following array:
temp=(9,4,9,3,8,4,9,8)
and i want to sort it but instead of returning
temp=(9,9,9,8,8,4,4,3)
i want it to return the index of the value like
temp=(1,3,7,5,8,2,6,4).
Any help is appreciated. Thank you in advance!
Try this:
Sub Tester()
Dim arr, v, i, arr2()
arr = Array(9, 4, 9, 3, 8, 4, 9, 8)
ReDim arr2(LBound(arr) To UBound(arr))
Debug.Print "Original", Join(arr, ",")
For i = LBound(arr2) To UBound(arr2)
arr2(i) = Application.Large(arr, i + 1)
Next i
Debug.Print "Sorted", Join(arr2, ",")
For i = LBound(arr2) To UBound(arr2)
v = Application.Match(arr2(i), arr, 0)
arr2(i) = v 'save the position
arr(v - 1) = vbNull 'remove the found value
Next i
Debug.Print "Positions", Join(arr2, ",")
End Sub
EDIT: without the intermediate sort
Sub Tester2()
Dim arr, v, i, arr2()
arr = Array(9, 4, 9, 3, 8, 4, 9, 8)
ReDim arr2(LBound(arr) To UBound(arr))
For i = LBound(arr) To UBound(arr)
v = Application.Match(Application.Large(arr, 1), arr, 0)
arr(v - 1) = vbNull
arr2(i) = v
Next i
Debug.Print "Positions", Join(arr2, ",")
End Sub
Here is another algo using only native VBA functions, i.e. no Excel functions such as Application.Match etc., which should be much faster for large arrays. Takes about 5 seconds for an array of ca. 9000 elements. It returns the array of indices sort_idx as well as the array of sorted values arr_sorted. Note: the array here is 2D with any number of rows and 1 column, taken from column A on sheet "1". Can be easily adapted for a 1D array.
Sub cost_min()
'Get data
arr = Range(Sheets("1").Range("A1"), Sheets("1").Range("A1").End(xlDown)).Value2
'Sort price curve & get indices
Dim sort_idx(), arr_sorted()
ReDim sort_idx(1 To UBound(arr)), arr_sorted(1 To UBound(arr))
arr_2 = arr 'create copy to edit while sorting
For i = 1 To UBound(arr)
'Get max, record idx & value
max_val = arr_2(1, 1)
j = 1
sort_idx(i) = j
arr_sorted(i) = max_val
For j = 1 To UBound(arr_2)
If arr_2(j, 1) > max_val Then
max_val = arr_2(j, 1)
sort_idx(i) = j
arr_sorted(i) = max_val
End If
Next j
'Replace max found with null
arr_2(sort_idx(i), 1) = vbNull
Next i
End Sub