按特定值分组提取多列极值的VBA代码优化与实现求助

核心思路 #

• 用Scripting.Dictionary存储每个F列分组对应的目标列数据集合，自动去重分组，避免原代码中Match函数引发的1004错误
• 批量读取/写入数组，减少与工作表的交互次数，彻底解决运行速度慢的问题
• 对每个分组的目标列数据单独计算最大值、最小值，确保结果准确

完整VBA代码 #

Sub ExtractGroupedExtremes()
    Dim wsInput As Worksheet, wsOutput As Worksheet
    Dim lastRow As Long
    Dim dataArr As Variant, resultArr As Variant
    Dim dict As Object
    Dim key As Variant
    Dim i As Long, j As Long, k As Long, m As Long
    Dim targetCols As Variant ' 定义需要提取极值的列号
    
    ' --------------------------
    ' 自定义设置：修改为你的目标列号
    ' 示例：要处理B、C、D列，就写Array(2, 3, 4)
    targetCols = Array(2, 3, 4)
    ' --------------------------
    
    ' 初始化工作表
    Set wsInput = ThisWorkbook.Worksheets("Input")
    On Error Resume Next
    Set wsOutput = ThisWorkbook.Worksheets("Output")
    If Err.Number <> 0 Then
        Set wsOutput = ThisWorkbook.Worksheets.Add
        wsOutput.Name = "Output"
    End If
    On Error GoTo 0
    wsOutput.Cells.Clear ' 清空输出表旧数据
    
    ' 批量读取Input表数据到数组
    lastRow = wsInput.Cells(wsInput.Rows.Count, "F").End(xlUp).Row
    dataArr = wsInput.Range("A1:" & wsInput.Cells(lastRow, wsInput.Cells(1, wsInput.Columns.Count).End(xlToLeft).Column).Address).Value
    
    ' 初始化Dictionary存储分组数据
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 遍历数据填充Dictionary
    For i = 2 To lastRow ' 假设第1行是表头，从第2行开始读取数据
        Dim groupKey As Variant
        groupKey = dataArr(i, 6) ' F列是第6列
        
        If Not dict.Exists(groupKey) Then
            ' 首次遇到该分组，初始化存储数组
            dict(groupKey) = Array(Array(dataArr(i, targetCols(0)), dataArr(i, targetCols(1)), dataArr(i, targetCols(2))))
        Else
            ' 已有该分组，追加新数据到存储数组
            Dim tempArr As Variant
            tempArr = dict(groupKey)
            ReDim Preserve tempArr(UBound(tempArr) + 1)
            tempArr(UBound(tempArr)) = Array(dataArr(i, targetCols(0)), dataArr(i, targetCols(1)), dataArr(i, targetCols(2)))
            dict(groupKey) = tempArr
        End If
    Next i
    
    ' 准备结果数组
    ReDim resultArr(1 To dict.Count + 1, 1 To 1 + UBound(targetCols) * 2 + 1)
    
    ' 写入表头
    resultArr(1, 1) = "分组值"
    k = 2
    For j = LBound(targetCols) To UBound(targetCols)
        resultArr(1, k) = wsInput.Cells(1, targetCols(j)).Value & "_最大值"
        resultArr(1, k + 1) = wsInput.Cells(1, targetCols(j)).Value & "_最小值"
        k = k + 2
    Next j
    
    ' 计算每个分组的极值并写入结果数组
    i = 2
    For Each key In dict.Keys
        resultArr(i, 1) = key
        k = 2
        For j = LBound(targetCols) To UBound(targetCols)
            ' 提取当前列的所有数据
            Dim colData As Variant
            ReDim colData(1 To UBound(dict(key)) + 1)
            For m = LBound(dict(key)) To UBound(dict(key))
                colData(m + 1) = dict(key)(m)(j)
            Next m
            
            ' 计算并写入极值
            resultArr(i, k) = WorksheetFunction.Max(colData)
            resultArr(i, k + 1) = WorksheetFunction.Min(colData)
            k = k + 2
        Next j
        i = i + 1
    Next key
    
    ' 批量写入结果到输出表
    wsOutput.Range(wsOutput.Cells(1, 1), wsOutput.Cells(UBound(resultArr), UBound(resultArr, 2))).Value = resultArr
    wsOutput.UsedRange.Columns.AutoFit ' 自动调整列宽
    
    ' 释放对象
    Set dict = Nothing
    Set wsInput = Nothing
    Set wsOutput = Nothing
    
    MsgBox "极值提取完成！", vbInformation
End Sub

关键细节说明 #

1. 自定义目标列：修改targetCols数组为你需要提取极值的列号（例如要处理G、H、I列，就写Array(7,8,9)）
2. 表头兼容：代码默认Input表表头在第1行，若你的表头位置不同，需调整循环起始行i=2的数值
3. 错误处理：自动判断Output表是否存在，不存在则新建，避免手动创建工作表的麻烦
4. 效率优化：全程用数组读写数据，避免循环操作单元格，比原代码速度提升数倍

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