VBA 从多维数组中得到 min/max

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

您可以避免通过 "assign value" 循环检查值和位置的两个循环：

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

非常有趣的问题。

我尝试检查性能，但我没有发现任何更快的东西。也许这对你有用。

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 使用 Array of Arrays（我曾希望它会是最快的，但不是 :( ):

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

VBA 从多维数组中得到 min/max

VBA get min/max from multidimensional array

arrays

excel

vba

max