VBA get min / max from multi-row array
I have the following example code:
Public Sub max_in_array()
Dim vararray(10, 10, 10) As Double
'Assign values to array
For i = 1 To 10
For j = 1 To 10
For k = 1 To 10
vararray(i, j, k) = i * j * k 'This will be more complicated in the actual code
Next k
Next j
Next i
'Find the maximum
Dim intmax As Double
intmax = 0
For i = 1 To 10
For j = 1 To 10
For k = 1 To 10
If vararray(i, j, k) > intmax Then
Intmax = vararray(i, j, k)
End If
Next k
Next j
Next i
MsgBox "max = " & CStr(intmax)
'Find maximum position
For i = 1 To 10
For j = 1 To 10
For k = 1 To 10
If vararray(i, j, k) = intmax Then
MsgBox "Maximum indices are " & CStr(i) & " " & CStr(j) & " " & CStr(k)
End If
Next k
Next j
Next i
End Sub
In actual code, the vararray will probably be 6 or 7 dimensional, with each dimension having up to 1000 values. This means that the loops are time consuming, which I want to constrain.
Is there a way to make the last two segments of the loop (find the maximum and get the indices) faster? (For example WorsheetFunction.Max (), but this only works with max 2 sizes)
Thanks in advance!
source to share
You can avoid the two loop and position reference values through an assign loop:
Public Sub max_in_array()
Dim vararray(10, 10, 10) As Double
Dim Pos(1 To 3)
'Assign values to array
For i = 1 To 10
For j = 1 To 10
For k = 1 To 10
vararray(i, j, k) = i * j * k 'This will be more complicated in the actual code
If vararray(i, j, k) > Intmax Then
Intmax = vararray(i, j, k)
Pos(1) = i
Pos(2) = j
Pos(3) = k
End If
Next k
Next j
Next i
MsgBox "Maximum indices are " & Join(Pos, " ")
End Sub
source to share
I don't think there is a way to avoid the loop, although it is possible that a compiled library function might offer some improvement for many (large) dimensions. But which is an order of magnitude (or more) more difficult and probably shouldn't try if you don't.
I would store the values i
, j
and k
every time I find a new maximum:
Dim intmax As Double, max_i As Integer, max_j As Integer, max_k As Integer
intmax = 0
max_i = -1, max_j = -1, max_k = -1
For i = 1 To 10
For j = 1 To 10
For k = 1 To 10
If vararray(i, j, k) > intmax Then
Intmax = vararray(i, j, k)
max_i = i
max_j = j
max_k = k
End If
Next
Next
Next
MsgBox "Maximum indices are " & CStr(max_i) & " " & CStr(max_j) & " " & CStr(max_k)
source to share
A very interesting question.
I am trying to test the performance, but I am not finding anything much faster. Mayby it will be helpful for you.
Sub TestArrMaxMin()
NrOfLoops = 100
'1 test
Start = Timer
For i = 1 To NrOfLoops
max_in_array
Next i
Debug.Print Timer - Start & " max_in_array Loops=" & NrOfLoops
'2 test
Start = Timer
For i = 1 To NrOfLoops
max_in_array_of_array
Next i
Debug.Print Timer - Start & " max_in_array_of_array Loops=" & NrOfLoops
'3 test
Start = Timer
For i = 1 To NrOfLoops
max_in_array_each_in
Next i
Debug.Print Timer - Start & " max_in_array_each_in Loops=" & NrOfLoops
End Sub
Your submarine with a slight modification:
Public Sub max_in_array()
Dim VarArray(100, 100, 100) As Double
'Assign values to array
For i = 0 To 100
For j = 0 To 100
For k = 0 To 100
VarArray(i, j, k) = Rnd() 'This will be more complicated in the actual code
Next k
Next j
Next i
'Find the maximum
Dim IntMax As Double
IntMax = 0
For i = 0 To 100
For j = 0 To 100
For k = 0 To 100
If VarArray(i, j, k) > IntMax Then
IntMax = VarArray(i, j, k)
IntMaxAdr = i & "," & j & "," & k
End If
Next k
Next j
Next i
'Debug.Print "max = " & CStr(IntMax)
'Debug.Print "Maximum indices are " & IntMaxAdr
End Sub
Sub using an array of arrays (I had hopes it would be the fastest, but not :():
Public Sub max_in_array_of_array()
Dim VarArray(100, 100) As Double
Dim ArrayOfArrays(100) As Variant
'Assign values to array
For i = 0 To 100
For j = 0 To 100
For k = 0 To 100
VarArray(j, k) = Rnd() 'This will be more complicated in the actual code
Next k
Next j
ArrayOfArrays(i) = VarArray
Next i
'Find the maximum
Dim IntMax As Double
IntMax = 0
Dim IntMaxAdr As Integer
IntMaxAdr = 0
For i = 0 To 100
Max = Application.WorksheetFunction.Max(ArrayOfArrays(i))
If Max > IntMax Then
IntMax = ArrMember
IntMaxAdr = i
End If
Next i
'find addres
adr_i = IntMaxAdr
For j = 0 To 100
For k = 0 To 100
If IntMax = ArrayOfArrays(adr_i)(j, k) Then
adr_j = j
adr_k = k
Exit For
End If
Next k
Next j
'Debug.Print "max = " & CStr(IntMax)
'Debug.Print "Maximum indices are " & adr_i & "," & adr_j & "," & adr_k
End Sub
And one last use for each, a little faster:
Public Sub max_in_array_each_in()
Dim VarArray(100, 100, 100) As Double
'Assign values to array
For i = 0 To 100
For j = 0 To 100
For k = 0 To 100
VarArray(i, j, k) = Rnd() 'This will be more complicated in the actual code
Next k
Next j
Next i
'Find the maximum
Dim IntMax As Double
IntMax = 0
Dim ArrMemberIndex As Long
ArrMemberIndex = -1
For Each ArrMember In VarArray
ArrMemberIndex = ArrMemberIndex + 1
If ArrMember > IntMax Then
IntMax = ArrMember
IntMaxAdr = ArrMemberIndex
End If
Next
'calculate i,j,k
adr_i = IntMaxAdr Mod 101
adr_j = Int(IntMaxAdr / 101) Mod 101
adr_k = Int(IntMaxAdr / (101 ^ 2))
'Debug.Print "max = " & CStr(IntMax)
'Debug.Print "Maximum indices are " & adr_i & "," & adr_j & "," & adr_k
End Sub
Results:
TestArrMaxMin
25,67969 max_in_array Loops=100
31,46484 max_in_array_of_array Loops=100
21,24609 max_in_array_each_in Loops=100
source to share