按ID保留value1和value2最小值所在行的Excel VBA实现需求

原代码的RemoveDuplicates方法仅能处理重复值删除，无法实现按ID分组并保留指定字段极值行的需求。下面是一个可扩展的VBA方案，支持轻松添加更多筛选条件：

核心思路 #

1. 遍历数据，用字典按ID分组，记录每个ID下各目标字段的最小值
2. 再次遍历数据，标记需要保留的行（满足任意一个字段极值条件的行）
3. 删除未标记的行，最终保留符合要求的记录

可扩展VBA代码 #

Sub KeepExtremeRows()
    Dim ws As Worksheet
    Dim lastRow As Long, i As Long
    Dim idDict As Object
    Dim currentID As String, keepRow As Boolean
    Dim minVal1 As Double, minVal2 As Double
    ' 如果需要添加更多筛选字段，在这里声明对应的最小值变量，比如minVal3 As Double
    
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    Set idDict = CreateObject("Scripting.Dictionary")
    
    ' 第一步：遍历数据，记录每个ID下各字段的最小值
    For i = 2 To lastRow ' 假设第一行是表头
        currentID = ws.Cells(i, "A").Value ' ID列是A列，可根据实际调整
        ' 获取当前行的value1和value2（假设value1在B列，value2在C列，可调整）
        Dim val1 As Double, val2 As Double
        val1 = ws.Cells(i, "B").Value
        val2 = ws.Cells(i, "C").Value
        
        If Not idDict.Exists(currentID) Then
            ' 首次遇到该ID，初始化各字段最小值
            idDict(currentID) = Array(val1, val2)
            ' 如果添加更多字段，这里改成Array(val1, val2, val3,...)
        Else
            ' 更新最小值
            minVal1 = idDict(currentID)(0)
            minVal2 = idDict(currentID)(1)
            ' 如果添加更多字段，这里取出对应的minVal3 = idDict(currentID)(2)等
            
            If val1 < minVal1 Then minVal1 = val1
            If val2 < minVal2 Then minVal2 = val2
            ' 如果添加更多字段，这里加上If val3 < minVal3 Then minVal3 = val3
            
            idDict(currentID) = Array(minVal1, minVal2)
            ' 如果添加更多字段，这里改成Array(minVal1, minVal2, minVal3,...)
        End If
    Next i
    
    ' 第二步：标记需要保留的行（从下往上遍历，避免删除行导致索引混乱）
    For i = lastRow To 2 Step -1
        currentID = ws.Cells(i, "A").Value
        val1 = ws.Cells(i, "B").Value
        val2 = ws.Cells(i, "C").Value
        keepRow = False
        
        ' 判断当前行是否满足任意一个极值条件
        If val1 = idDict(currentID)(0) Then keepRow = True
        If val2 = idDict(currentID)(1) Then keepRow = True
        ' 如果添加更多字段，这里加上If val3 = idDict(currentID)(2) Then keepRow = True
        
        ' 不满足则删除该行
        If Not keepRow Then
            ws.Rows(i).Delete
        End If
    Next i
    
    Set idDict = Nothing
    Set ws = Nothing
    MsgBox "处理完成！"
End Sub

扩展说明 #

如果需要添加更多筛选条件（比如保留value3最小值的行），只需做3处修改：

• 在变量声明部分添加对应的minVal3 As Double和val3 As Double
• 在第一步初始化和更新字典的逻辑中，把数组扩展为包含val3/minVal3
• 在第二步的判断逻辑中，增加val3 = idDict(currentID)(2) Then keepRow = True的判断

注意事项 #

• 请根据实际数据列调整代码中ID列（A列）、value1列（B列）、value2列（C列）的索引
• 若数据包含空值，建议先处理空值，避免字典初始化或最小值判断出错

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