Find the indices for the minimum values in a multi dimensional array in VBA - vba

Question

In the code below I have an n x n x n array of values. I need to identify the indices that contain the minimum, second to minimum, third to minimum, ..., and put them into their own array to be used later on in the code. CC is currently defined as a 11 x 11 x 11 array and I need to identify the minimums. Below is the setup of my array CC that contains the values. n is defined as the length of the array h2s, which happens to be 11 in this case. h2st is the sum of the values in h2s.
h2s = [1.099, 0.988, 0.7, 0.8, 0.5, 0.432, 0.8, 1.12, 0.93, 0.77, 0.658]
h2st = 0
n = Ubound(h2s) - Lbound(h2s) + 1
For i = 1 to n
h2st = h2st + h2s(i)
Next i
For i = 1 To n
For j = i + 1 To n
For k = j + 1 To n
CC(i, j, k) = Abs(h2st - ((h2s(i) + h2s(j) + h2s(k)) * (n / 3)))
Next k
Next j
Next i

Answer 1

You can use this function that takes a multidimensional array and returns an array of its n minimum values, where n is a parameter. Importantly, the elements in the returned array are a data structure of Type Point, containing the coordinates and the value of each found point.
You can easily adjust it for finding the n max values, just by changing two characters in the code, as indicated in comments (the initialization and the comparison)
Option Explicit
Type Point
X As Long
Y As Long
Z As Long
value As Double
End Type
Function minVals(ar() As Double, nVals As Long) As Point()
Dim i As Long, j As Long, k As Long, m As Long, n As Long, pt As Point
'Initialize returned array with max values.
pt.value = 9999999# ' <-------- change to -9999999# for finding max
ReDim ret(1 To nVals) As Point
For i = LBound(ret) To UBound(ret): ret(i) = pt: Next
For i = LBound(ar, 1) To UBound(ar, 1)
For j = LBound(ar, 2) To UBound(ar, 2)
For k = LBound(ar, 3) To UBound(ar, 3)
' Find first element greater than this value in the return array
For m = LBound(ret) To UBound(ret)
If ar(i, j, k) < ret(m).value Then ' <------- change to > for finding max
' shift the elements on this position and insert the current value
For n = UBound(ret) To m + 1 Step -1: ret(n) = ret(n - 1): Next n
pt.X = i: pt.Y = j: pt.Z = k: pt.value = ar(i, j, k)
ret(m) = pt
Exit For
End If
Next m
Next k
Next j
Next i
minVals = ret
End Function
Sub Test()
Dim i As Long, j As Long, k As Long, pt As Point
Const n As Long = 11
ReDim CC(1 To n, 1 To n, 1 To n) As Double
For i = 1 To n
For j = 1 To n
For k = 1 To n
CC(i, j, k) = Application.RandBetween(100, 100000)
Next k
Next j
Next i
' Testing the function: get the smalles 5 values and their coordinates
Dim mins() As Point: mins = minVals(CC, 5)
' Printing the results
For i = LBound(mins) To UBound(mins)
Debug.Print mins(i).value, mins(i).X, mins(i).Y, mins(i).Z
Next
End Sub