Fetch the maximum value from an array - vba

I have an array that looks like this:
Dim values(1 To 3) As String
values(1) = Sheets("risk_cat_2").Cells(4, 6).Value
values(2) = Sheets("risk_cat_2").Cells(5, 6).Value
values(3) = Sheets("risk_cat_2").Cells(6, 6).Value
What I would like to do now is get the maximum value from all the values in string. Is there an easy way in VBA to fetch the max value from an array?

Is there an easy way in VBA to fetch the max value from an array?
Yes - if the values are numeric. You can use WorksheetFunction.Max in VBA.
For strings - this won't work.
Sub Test2()
Dim arr(1 To 3) As Long
arr(1) = 100
arr(2) = 200
arr(3) = 300
Debug.Print WorksheetFunction.Max(arr)
End Sub

Simple loop would do the trick
Dim Count As Integer, maxVal As Long
maxVal = Values(1)
For Count = 2 to UBound(values)
If Values(Count) > maxVal Then
maxVal = Values(Count)
End If
Next Count

The easiest way to retrieve the maximum (I can think of) is iterating through the array and comparing the values. The following two functions do just that:
Option Explicit
Public Sub InitialValues()
Dim strValues(1 To 3) As String
strValues(1) = 3
strValues(2) = "af"
strValues(3) = 6
Debug.Print GetMaxString(strValues)
Debug.Print GetMaxNumber(strValues)
End Sub
Public Function GetMaxString(ByRef strValues() As String) As String
Dim i As Long
For i = LBound(strValues) To UBound(strValues)
If GetMaxString < strValues(i) Then GetMaxString = strValues(i)
Next i
End Function
Public Function GetMaxNumber(ByRef strValues() As String) As Double
Dim i As Long
For i = LBound(strValues) To UBound(strValues)
If IsNumeric(strValues(i)) Then
If CDbl(strValues(i)) > GetMaxNumber Then GetMaxNumber = CDbl(strValues(i))
End If
Next i
End Function
Note, that each time a string (text) array is passed to the function. Yet, one function is comparing strings (text) while the other is comparing numbers. The outcome is quite different!
The first function (comparing text) will return (with the above sample data) af as the maximum, while the second function will only consider numbers and therefore returns 6 as the maximum.

Solution for Collection.
Sub testColl()
Dim tempColl As Collection
Set tempColl = New Collection
tempColl.Add 57
tempColl.Add 10
tempColl.Add 15
tempColl.Add 100
tempColl.Add 8
Debug.Print largestNumber(tempColl, 2) 'prints 57
End Sub
Function largestNumber(inputColl As Collection, indexMax As Long)
Dim element As Variant
Dim result As Double
result = 0
Dim i As Long
Dim previousMax As Double
For i = 1 To indexMax
For Each element In inputColl
If i > 1 And element > result And element < previousMax Then
result = element
ElseIf i = 1 And element > result Then
result = element
End If
Next
previousMax = result
result = 0
Next
largestNumber = previousMax
End Function

Related

Summing up two arrays or matrices element by element

I have two variables defined like this:
Per_Mnd = Worksheets("Sheet1").Range("G2:G8").Value
Per_Mnd2 = Worksheets("Sheet2").Range("G2:G8").Value
Obviously both Per_Mnd and Per_Mnd2 have 7 rows and 1 column. Now I want to sum them up element by element, getting another 7×1 array. How do I do it?
And what is they are defined by matrix
Per_Mnd = Worksheets("Sheet1").Range("G2:H8").Value
Per_Mnd2 = Worksheets("Sheet2").Range("G2:H8").Value
How can I quickly sum them up element by element?
thanks!
You can simply evaluate an INDEX formula to return the array:
Sub Test()
Dim oarr As Variant
Dim Per_Mnd As Variant
Dim Per_Mnd2 As Variant
Per_Mnd = Worksheets("Sheet1").Range("G2:G8").Value
Per_Mnd2 = Worksheets("Sheet2").Range("G2:G8").Value
With Application
oarr = .Transpose(.Evaluate("INDEX({" & Join(.Transpose(Per_Mnd), ",") & "}+{" & Join(.Transpose(Per_Mnd2), ",") & "},)"))
End With
Debug.Print oarr(3, 1)
End Sub
Note: this only works with single column arrays of the same size.
If you want to sum a matrix, the VBA way is WorksheetFunction.SumProduct
Take the example below, returning 60 -> 1*10+2*10+3*10
Public Sub TestMe()
Dim el1 As Variant
Dim el2 As Variant
Dim res As Variant
el1 = Application.Transpose(Range("A1:A3"))
el2 = Application.Transpose(Range("B1:B3"))
Debug.Print WorksheetFunction.SumProduct(el1, el2)
ReDim res(1 To UBound(el1))
Dim cnt As Long
For cnt = LBound(el1) To UBound(el1)
res(cnt) = el1(cnt) + el2(cnt)
Next cnt
End Sub
The idea of Application.Transpose() is to present the Range() as a one dimensional array. Once we do so, we introduce res(1 to UBound(el1) where we write the product per element. Or you can even do the SumArray as a function, returning the new array:
Public Function SumArray(arr1 As Variant, arr2 As Variant) As Variant
ReDim res(1 To UBound(arr1))
Dim cnt As Long
For cnt = LBound(arr1) To UBound(arr1)
res(cnt) = arr1(cnt) + arr2(cnt)
Next cnt
SumArray = res
End Function

Function is only working for certain subranges?

Main point of this function is to return the most common movie genre.
Function MoviesByGenre(genreRng As Range) As String
Dim genreList(1 To 4) As String
Dim current As Integer
current = 1
For i = 1 To genreRng.count
Dim found As Integer
found = 0
For j = 1 To current
If genreList(j) = genreRng.Cells(i) Then
found = 1
Exit For
End If
Next j
If found = 0 Then
genreList(current) = genreRng.Cells(i)
current = current + 1
End If
Next i
Dim genreCount(1 To 4) As Integer
For i = 1 To 4
Dim count As Integer
count = 0
For j = 1 To genreRng.count
If genreRng.Cells(j) = genreList(i) Then
count = count + 1
End If
Next j
genreCount(i) = count
Next i
MoviesByGenre = FindMax(genreCount, genreList)
End Function
Now my FindMax function looks like this:
Function FindMax(valueArray, nameArray) As String
Dim max As Double
max = valueArray(LBound(valueArray))
For i = LBound(valueArray) + 1 To UBound(valueArray)
If valueArray(i) > valueArray(max) Then
max = i
End If
Next i
FindMax = nameArray(max)
End Function
FindMax appears to work well in other areas, but depending on the range I use for MoviesByGenre, it may or may not work. (sometimes it'll give me #VALUE!, other times it'll give me the actual most common movie genre, and i'm not sure why.) I'm using Excel 2016 for MacOS.
Do you mean something like that
Sub Test()
Dim a As Variant
a = Range("A1:A7").Value
MsgBox FindMax(a)
End Sub
Function FindMax(valueArray) As String
Dim max As Double
Dim i As Long
max = valueArray(LBound(valueArray), 1)
For i = LBound(valueArray) + 1 To UBound(valueArray)
If valueArray(i, 1) > max Then
max = valueArray(i, 1)
End If
Next i
FindMax = max
End Function

VBA comparing multiple variables

There any way to compare multiple variables in VBA? For example:
Dim x As Integer
Dim y As Integer
Dim z As Integer
x = 99
y = 2
z = 3
I would like to return the smallest of the values.
I understand I could use select case x > y for all possible permutations but that seems unwieldy for more than 3 variables.
I have tried the worksheet function
solution = Application.WorksheetFunction.Min(x, y, z)
but that returns 2 and I would like it to return the variable name to be passed to another function.
many thanks,
Edit: My apologies if this was confusing, I am still a VBA novice. Here's my problem a little more generally:
I have a list of codes that correspond to names, many names per code. I want to loop through every name per code and count the number of instances that name appears on a list and choose the name with the LEAST occurrences. (could be 0 or could be the same as another name). obviously if there were 2 names it would be easy to do a if x>y then but I'm stumped as for comparing more than 3. Thanks for reading.
Use a public array rather than multiple variables. This will make it easy to iterate through them all and get the highest value, as well as reference the variable with the highest value later on:
Public myArray(0 To 2) As Integer
Public index As Integer
Public Sub calcMin()
Dim i As Integer
Dim maxValue As Integer
myArray(0) = 99
myArray(1) = 2
myArray(2) = 3
For i = 0 To UBound(myArray)
If myArray(i) < maxValue Then
maxValue = myArray(i)
index = i
End If
Next i
End Sub
Function yourFunction(valueToPass As Integer)
'your function's code here
End Function
Then pass the variable to yourFunction like so: yourFunction(myArray(index))
Same idea as Mike's but with an example to call a sub with the min value found:
Sub main()
Dim arrComp(2) As Integer
arrComp(0) = 99
arrComp(1) = 2
arrComp(2) = 3
'It is important to initialize the tmpVal to a value from the array
'to consider the chance where negative and positive values are used
Dim tmpVal As Integer: tmpVal = arrComp(LBound(arrComp))
Dim i As Integer, minIndex As Integer
For i = LBound(arrComp) To UBound(arrComp)
If arrComp(i) < tmpVal Then
tmpVal = arrComp(i)
minIndex = i
End If
Next i
showMinVal arrComp(minIndex)
End Sub
Sub showMinVal(MinVal As Integer)
MsgBox "The min value is " & MinVal
End Sub
Or, a workaround if you want the name associated to the value, you could define a new Type:
'Types must be declared at the top of the module
Type tVarName
varName As String
varVal As Integer
End Type
Sub main()
Dim arrComp(2) As tVarName
arrComp(0).varName = "x"
arrComp(0).varVal = 99
arrComp(1).varName = "y"
arrComp(1).varVal = 2
arrComp(2).varName = "z"
arrComp(2).varVal = 3
Dim tmpVal As Integer: tmpVal = arrComp(LBound(arrComp)).varVal
Dim i As Integer, minIndex As Integer
For i = LBound(arrComp) To UBound(arrComp)
If arrComp(i).varVal < tmpVal Then
tmpVal = arrComp(i).varVal
minIndex = i
End If
Next i
showMinVal arrComp(minIndex)
End Sub
'Sub showing min value along with the name associated to it
Sub showMinVal(MinVal As tVarName)
MsgBox "The min value is " & MinVal.varName & " = " & MinVal.varVal
End Sub

FILTER Function for integers - VBA

I searched the website but was not succesfful and tried doing some research on this but facing with " Type Mismatch" error.
I declared an array as integer type but the FILTER function seems to work only with STRING's. Can you please let me know how I can use the FILTER function for integers?
If UBound(Filter(CntArr(), count)) > 0 Then
msgbox "found"
End If
as i understand you need to know if specified count present in array. You can use for loop for it:
Dim found as Boolean
found = False
For i = 0 To UBound (CntArr())
If CntArr(i) = count Then
found = True
Exit For
End If
Next i
If found Then msgbox "found" End If
Below I have created IsIntegerInArray() function that returns boolean. Follow the two Subs for an example of integer array declaration. Declaring array as Integer should also prevent some unnecessary bugs caused by implicit data conversion.
Sub test_int_array()
Dim a() As Integer
ReDim a(3)
a(0) = 2
a(1) = 15
a(2) = 16
a(3) = 8
''' expected result: 1 row for each integer in the array
Call test_printing_array(a)
End Sub
Sub test_printing_array(arr() As Integer)
Dim i As Integer
For i = 1 To 20
If IsIntegerInArray(i, arr) Then
Debug.Print i & " is in array."
End If
Next i
End Sub
Function IsIntegerInArray(integerToBeFound As Integer, arr() As Integer) As Boolean
Dim i As Integer
''' incorrect approach:
''' IsIntegerInArray = (UBound(Filter(arr, integerToBeFound)) > -1) ' this approach searches for string, e.g. it matches "1" in "12"
''' correct approach:
IsIntegerInArray = False
For i = LBound(arr) To UBound(arr)
If arr(i) = integerToBeFound Then
IsIntegerInArray = True
Exit Function
End If
Next i
End Function

How can I list all the combinations that meet certain criteria using Excel VBA?

Which are the combinations that the sum of each digit is equal to 8 or less, from 1 to 88,888,888?
For example,
70000001 = 7+0+0+0+0+0+0+1 = 8 Should be on the list
00000021 = 0+0+0+0+0+0+2+1 = 3 Should be on the list.
20005002 = 2+0+0+0+5+0+0+2 = 9 Should not be on the list.
Sub Comb()
Dim r As Integer 'Row (to store the number)
Dim i As Integer 'Range
r = 1
For i = 0 To 88888888
If i = 8
'How can I get the sum of the digits on vba?
ActiveSheet.Cells(r, 1) = i
r = r + 1
End If
Else
End Sub
... Is this what you're looking for?
Function AddDigits(sNum As String) As Integer
Dim i As Integer
AddDigits = 0
For i = 1 To Len(sNum)
AddDigits = AddDigits + CInt(Mid(sNum, i, 1))
Next i
End Function
(Just remember to use CStr() on the number you pass into the function.
If not, can you explain what it is you want in a bit more detail.
Hope this helps
The method you suggest is pretty much brute force. On my machine, it ran 6.5min to calculate all numbers. so far a challenge I tried to find a more efficient algorithm.
This one takes about 0.5s:
Private Const cIntNumberOfDigits As Integer = 9
Private mStrNum As String
Private mRng As Range
Private Sub GetNumbers()
Dim dblStart As Double
Set mRng = Range("a1")
dblStart = Timer
mStrNum = Replace(Space(cIntNumberOfDigits), " ", "0")
subGetNumbers 8
Debug.Print (Timer - dblStart) / 10000000, (Timer - dblStart)
End Sub
Private Sub subGetNumbers(intMaxSum As Integer, Optional intStartPos As Integer = 1)
Dim i As Integer
If intStartPos = cIntNumberOfDigits Then
Mid(mStrNum, intStartPos, 1) = intMaxSum
mRng.Value = Val(mStrNum)
Set mRng = mRng.Offset(1)
Mid(mStrNum, intStartPos, 1) = 0
Exit Sub
End If
For i = 0 To intMaxSum
Mid(mStrNum, intStartPos, 1) = CStr(i)
subGetNumbers intMaxSum - i, intStartPos + 1
Next i
Mid(mStrNum, intStartPos, 1) = 0
End Sub
It can be sped up further by about factor 10 by using arrays instead of writing directly to the range and offsetting it, but that should suffice for now! :-)
As an alternative, You can use a function like this:
Function isInnerLowr8(x As Long) As Boolean
Dim strX As String, inSum As Long
isInnerLowr8 = False
strX = Replace(CStr(x), "0", "")
For i = 1 To Len(strX)
Sum = Sum + Val(Mid(strX, i, 1))
If Sum > 8 Then Exit Function
Next i
isInnerLowr8 = True
End Function
Now change If i = 8 to If isInnerLowr8(i) Then.