如何在VBA数组arr1、arr2中直接查找动态范围最值（无需写入工作表）

我有一段可正常运行的VBA代码，功能如下：从工作表"Rawdata"的B列（共58000行）生成数组arr，将其拆分为仅包含负值的数组arr1和仅包含正值的数组arr2，并分别写入C列和D列；随后利用E列指定的时间范围以及F、G列的AdjustFactor参数进行循环，从对应范围中获取最值并写入H列和I列。

我希望优化这段代码，无需将arr1和arr2写入工作表，直接在这两个数组中查找对应动态范围的最值。请问该如何实现？

原代码如下：

Sub Macro1()

Dim i, j, LastRow As Long
Dim arr, arr1, arr2, Time, NegativeRange, PositiveRange, NegativeMin, PositiveMin, AdjustFactor As Variant

    With Sheets("Rawdata")
        
        i = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Cells(1, 2).Resize(i, 1).Value
        arr1 = .Cells(1, 3).Resize(i, 1)
        arr2 = .Cells(1, 4).Resize(i, 1)
                
        For i = LBound(arr, 1) To UBound(arr, 1)
            arr1(i, 1) = IIf(arr(i, 1) >= 0, vblank, arr(i, 1))
            arr2(i, 1) = IIf(arr(i, 1) < 0, vblank, arr(i, 1))
        Next i
                
        .Cells(1, 3).Resize(i - 1, 1) = arr1
        .Cells(1, 4).Resize(i - 1, 1) = arr2
    
    End With
    
    LastRow = Cells(Rows.Count, 5).End(xlUp).Row
    
    AdjustFactor = Range(Cells(1, 6), Cells(LastRow, 7))
    
    PositiveMin = Range(Cells(1, 8), Cells(LastRow, 8))
    NegativeMin = Range(Cells(1, 9), Cells(LastRow, 9))
    
    For j = 1 To LastRow

        Time = Range("A:A").Find(what:=Cells(j, 5).Value, LookIn:=xlValues, LookAt:=1, MatchCase:=True).Row
        PositiveRange = Range(Cells(Time + 10 * AdjustFactor(j, 1), 4), Cells(Time + 10 * AdjustFactor(j, 2), 4))
        NegativeRange = Range(Cells(Time + 10 * AdjustFactor(j, 1), 3), Cells(Time + 10 * AdjustFactor(j, 2), 3))
        PositiveMin(j, 1) = WorksheetFunction.Min(PositiveRange)
        NegativeMin(j, 1) = WorksheetFunction.Max(NegativeRange)

    Next j

    Range(Cells(1, 8), Cells(LastRow, 8)) = PositiveMin
    Range(Cells(1, 9), Cells(LastRow, 9)) = NegativeMin

End Sub

优化核心思路：完全在内存数组中处理正负值拆分和最值查找，彻底移除arr1、arr2的工作表写入操作，减少IO交互提升效率，同时用自定义函数替代工作表函数直接操作内存数据。

Sub OptimizedMacro()
    Dim i As Long, j As Long, lastRowRaw As Long, lastRowFactor As Long
    Dim arr As Variant, arrNegative As Variant, arrPositive As Variant
    Dim adjustFactor As Variant, timeValues As Variant
    Dim positiveMinArr As Variant, negativeMaxArr As Variant
    Dim targetRow As Long, startIdx As Long, endIdx As Long
    
    With Sheets("Rawdata")
        ' 读取原始数据与时间列到内存数组
        lastRowRaw = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Cells(1, 2).Resize(lastRowRaw, 1).Value
        timeValues = .Cells(1, 1).Resize(lastRowRaw, 1).Value
        
        ' 初始化内存中的正负值数组（无需关联工作表单元格）
        ReDim arrNegative(1 To lastRowRaw, 1 To 1)
        ReDim arrPositive(1 To lastRowRaw, 1 To 1)
        
        ' 拆分原始数据到正负数组
        For i = LBound(arr, 1) To UBound(arr, 1)
            arrNegative(i, 1) = IIf(arr(i, 1) < 0, arr(i, 1), Empty)
            arrPositive(i, 1) = IIf(arr(i, 1) >= 0, arr(i, 1), Empty)
        Next i
        
        ' 读取参数列与初始化结果数组
        lastRowFactor = .Cells(.Rows.Count, 5).End(xlUp).Row
        adjustFactor = .Cells(1, 6).Resize(lastRowFactor, 2).Value
        ReDim positiveMinArr(1 To lastRowFactor, 1 To 1)
        ReDim negativeMaxArr(1 To lastRowFactor, 1 To 1)
        
        ' 循环处理每个参数行
        For j = 1 To lastRowFactor
            ' 遍历数组查找目标时间对应的行号（替代Find方法，更稳定）
            targetRow = 0
            For i = 1 To lastRowRaw
                If timeValues(i, 1) = .Cells(j, 5).Value Then
                    targetRow = i
                    Exit For
                End If
            Next i
            
            If targetRow > 0 Then
                ' 计算范围索引并做边界校验
                startIdx = targetRow + 10 * adjustFactor(j, 1)
                endIdx = targetRow + 10 * adjustFactor(j, 2)
                startIdx = IIf(startIdx < 1, 1, startIdx)
                endIdx = IIf(endIdx > lastRowRaw, lastRowRaw, endIdx)
                
                ' 调用自定义函数从内存数组取最值
                positiveMinArr(j, 1) = GetArrayMin(arrPositive, startIdx, endIdx)
                negativeMaxArr(j, 1) = GetArrayMax(arrNegative, startIdx, endIdx)
            End If
        Next j
        
        ' 一次性写入结果到工作表
        .Cells(1, 8).Resize(lastRowFactor, 1) = positiveMinArr
        .Cells(1, 9).Resize(lastRowFactor, 1) = negativeMaxArr
    End With
End Sub

' 自定义函数：获取数组指定行范围内的最小值（忽略空值）
Function GetArrayMin(arr As Variant, startRow As Long, endRow As Long) As Double
    Dim i As Long
    Dim minVal As Double
    minVal = 1E+308 ' 初始化极大值
    
    For i = startRow To endRow
        If Not IsEmpty(arr(i, 1)) And arr(i, 1) < minVal Then
            minVal = arr(i, 1)
        End If
    Next i
    
    GetArrayMin = minVal
End Function

' 自定义函数：获取数组指定行范围内的最大值（忽略空值）
Function GetArrayMax(arr As Variant, startRow As Long, endRow As Long) As Double
    Dim i As Long
    Dim maxVal As Double
    maxVal = -1E+308 ' 初始化极小值
    
    For i = startRow To endRow
        If Not IsEmpty(arr(i, 1)) And arr(i, 1) > maxVal Then
            maxVal = arr(i, 1)
        End If
    Next i
    
    GetArrayMax = maxVal
End Function

关键优化点 #

• 移除工作表中间写入：arrNegative和arrPositive仅在内存中存在，不再写入C、D列，避免了大量不必要的工作表IO操作，58000行数据下速度提升明显。
• 自定义最值函数：直接遍历内存数组的指定区间计算最值，无需依赖WorksheetFunction读取单元格，逻辑更自主且效率更高。
• 数组查找替代Find：用内存数组遍历查找目标行号，比Range.Find更稳定，不会因格式或匹配规则问题出错。
• 边界校验：对计算出的范围索引做合法性校验，防止超出数组边界导致运行错误。
• 变量类型明确：修正原代码中变量类型模糊的问题，所有变量都明确指定类型，避免Variant类型的潜在性能损耗。

内容的提问来源于stack exchange，提问作者Fevzi