VBA多列最值提取优化求助：简化重复代码实现

优化思路 #

把需要处理的**目标1列（最值列）和目标2列（对应关联列）**的列号存到数组里，通过循环遍历每一组列对，一次性将整列数据读取到内存数组中计算，避免反复读写工作表，同时消除重复代码。

优化后的代码 #

Sub ExtractMultiColumnStats()
    Dim wsSource As Worksheet, wsDest As Worksheet
    Dim colPairs As Variant
    Dim i As Integer, lastRow As Long
    Dim dataArr As Variant, target1Arr As Variant, target2Arr As Variant
    Dim maxVal As Double, minVal As Double, minAssocVal As Variant
    Dim minRowIndex As Long
    
    ' 绑定数据源和目标工作表
    Set wsSource = ThisWorkbook.Worksheets("Wells_A")
    Set wsDest = ThisWorkbook.Worksheets("final")
    
    ' 定义要处理的列对：每一组是(目标1列号, 目标2列号)
    ' 对应C&A、F&D、I&G列
    colPairs = Array(Array(3, 1), Array(6, 4), Array(9, 7))
    
    ' 清空目标工作表的历史结果（可选操作）
    wsDest.Range("A1:C" & wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row).ClearContents
    
    ' 循环处理每一组列对
    For i = LBound(colPairs) To UBound(colPairs)
        ' 取出当前组的列号
        Dim target1Col As Integer, target2Col As Integer
        target1Col = colPairs(i)(0)
        target2Col = colPairs(i)(1)
        
        ' 获取数据源列的最后一行
        lastRow = wsSource.Cells(wsSource.Rows.Count, target1Col).End(xlUp).Row
        
        ' 一次性读取整列数据到内存数组（减少工作表IO，提升效率）
        dataArr = wsSource.Range(wsSource.Cells(2, target1Col), wsSource.Cells(lastRow, target2Col)).Value
        ' 拆分出目标1和目标2的独立数组
        target1Arr = Application.Index(dataArr, 0, 1)
        target2Arr = Application.Index(dataArr, 0, 2)
        
        ' 初始化最值参数
        maxVal = target1Arr(1, 1)
        minVal = target1Arr(1, 1)
        minRowIndex = 1
        
        ' 遍历数组计算最值及对应关联值
        Dim j As Long
        For j = 2 To UBound(target1Arr)
            ' 更新最大值
            If target1Arr(j, 1) > maxVal Then maxVal = target1Arr(j, 1)
            ' 更新最小值及对应行号
            If target1Arr(j, 1) < minVal Then
                minVal = target1Arr(j, 1)
                minRowIndex = j
            End If
        Next j
        
        ' 获取最小值对应的目标2值
        minAssocVal = target2Arr(minRowIndex, 1)
        
        ' 将结果写入final工作表
        With wsDest.Cells(i + 1, 1)
            .Value = maxVal
            .Offset(0, 1).Value = minVal
            .Offset(0, 2).Value = minAssocVal
        End With
    Next i
    
    ' 释放对象资源
    Set wsSource = Nothing
    Set wsDest = Nothing
    
    MsgBox "统计提取完成！", vbInformation
End Sub

关键优化点说明 #

• 列对数组：把需要处理的列组合存到colPairs数组里，后续新增列对只需在数组中添加元素，无需重复编写逻辑代码。
• 内存数组读写：一次性把整列数据读到内存数组中计算，避免频繁和工作表交互，数据量越大，效率提升越明显。
• 循环复用逻辑：通过外层循环遍历所有列对，复用同一套最值计算和结果写入逻辑，代码更简洁易维护。

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