VBA从多维数组中获取最小值/最大值

Question

我有以下示例代码：

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

在实际代码中，vararray可能是6维或7维，每个维度最多有1000个值。这意味着循环将花费大量时间，我想限制。

有没有办法让最后两个循环段（找到最大值并获得索引）更快？ （例如WorsheetFunction.Max（），但这仅适用于最多2个维度）

Answer 1

您可以通过“赋值”循环避免两个循环检查值和位置：

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，j和k的值：

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)

Answer 3

非常有趣的问题。

我尝试检查性能，但我没有发现更快。 Mayby这对你有用。

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

您的子修改很少：

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使用数组阵列（我有希望，它会是最快但不是:(）：

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

最后使用每个，更快一点：

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

结果：

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