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
