VBA get min/max from multidimensional array

Question

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 the actual code the vararray will probably be 6 or 7 dimensional with each dimension having up to 1000 values. That means the loops will take a lot of time, which I want to limit.

Is there a way to make the last two loop segments (finding the maximum and getting the indexes) faster? (E.g. WorsheetFunction.Max(), but this only works on maximum 2 dimensions)

Answer 1

You may avoid two loops checking values and position through the "assign value" 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

Answer 2

I don't think there's any way to avoid the loop, although it's possible that a compiled library function might offer some improvement for many (large) dimensions. But that's an order of magnitude (or more) harder and probably not to be attempted unless there's dire need.

I'd store the values of i, j & k each 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)