无循环VBA脚本需求：按Score差值规则去重保留指定行

一、无循环实现方案（ADODB.SQL） #

用SQL分组查询可以完全避免循环，直接按规则筛选目标行，效率远高于循环，适合大数据量场景：

Sub RemoveDuplicatesWithoutLoop()
    Dim conn As Object, rs As Object
    Dim strSQL As String
    Dim wsSource As Worksheet, wsResult As Worksheet
    
    ' 指定源数据工作表（替换成你的表名）
    Set wsSource = ThisWorkbook.Worksheets("Sheet1")
    ' 创建/指定结果工作表
    On Error Resume Next
    Set wsResult = ThisWorkbook.Worksheets("Result")
    If Err.Number <> 0 Then
        Set wsResult = ThisWorkbook.Worksheets.Add
        wsResult.Name = "Result"
    End If
    On Error GoTo 0
    
    ' 建立Excel文件的数据库连接
    Set conn = CreateObject("ADODB.Connection")
    conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & _
              ";Extended Properties=""Excel 12.0 Xml;HDR=YES;"""
    
    ' 编写SQL：先计算每个ID的Score极差，再按规则筛选保留行
    strSQL = "SELECT t1.ID, t1.Score, t1.Peak " & _
             "FROM [Sheet1$] t1 " & _
             "INNER JOIN (" & _
                 "SELECT ID, " & _
                        "MAX(Score) AS MaxScore, " & _
                        "MIN(Score) AS MinScore, " & _
                        "MAX(Peak) AS MaxPeak " & _
                 "FROM [Sheet1$] " & _
                 "GROUP BY ID) t2 ON t1.ID = t2.ID " & _
             "WHERE " & _
                 "(t2.MaxScore - t2.MinScore >= 0.02 AND t1.Score = t2.MaxScore) OR " & _
                 "(t2.MaxScore - t2.MinScore <= 0.01 AND t1.Peak = t2.MaxPeak)"
    
    ' 执行查询并导出结果
    Set rs = CreateObject("ADODB.Recordset")
    rs.Open strSQL, conn
    
    If Not rs.EOF Then
        ' 写入表头
        Dim i As Integer
        For i = 0 To rs.Fields.Count - 1
            wsResult.Cells(1, i + 1).Value = rs.Fields(i).Name
        Next i
        ' 写入数据
        wsResult.Range("A2").CopyFromRecordset rs
    End If
    
    ' 清理资源
    rs.Close: conn.Close
    Set rs = Nothing: Set conn = Nothing: Set wsSource = Nothing: Set wsResult = Nothing
    
    MsgBox "去重完成，结果已保存到Result工作表", vbInformation
End Sub

代码说明 #

1. 把Excel工作表当作数据库表处理，用子查询计算每个ID的Score最大/最小值、Peak最大值
2. 主查询根据Score差值判断，直接筛选出符合规则的行
3. 结果导出到新工作表，避免破坏原数据

二、循环脚本报错修复（附正确循环写法） #

新手写循环去重常踩的坑：遍历方向错误、浮点数精度忽略、工作表引用缺失，下面是修正后的循环脚本：

Sub RemoveDuplicatesWithLoop()
    Dim ws As Worksheet
    Dim lastRow As Long, i As Long, j As Long
    Dim currentID As String
    Dim maxScore As Double, maxPeak As Double
    Dim scoreDiff As Double
    
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' 从下往上遍历，避免删行后跳过数据
    For i = lastRow To 2 Step -1
        currentID = ws.Cells(i, "A").Value
        maxScore = ws.Cells(i, "B").Value
        maxPeak = ws.Cells(i, "C").Value
        
        ' 查找同ID的上一行
        For j = i - 1 To 2 Step -1
            If ws.Cells(j, "A").Value = currentID Then
                scoreDiff = Abs(maxScore - ws.Cells(j, "B").Value)
                If scoreDiff >= 0.02 Then
                    ' 保留Score更高的行
                    If ws.Cells(j, "B").Value > maxScore Then
                        ws.Rows(i).Delete
                        maxScore = ws.Cells(j, "B").Value
                        maxPeak = ws.Cells(j, "C").Value
                    Else
                        ws.Rows(j).Delete
                    End If
                ElseIf scoreDiff <= 0.01 Then
                    ' 保留Peak更高的行
                    If ws.Cells(j, "C").Value > maxPeak Then
                        ws.Rows(i).Delete
                        maxScore = ws.Cells(j, "B").Value
                        maxPeak = ws.Cells(j, "C").Value
                    Else
                        ws.Rows(j).Delete
                    End If
                End If
            End If
        Next j
    Next i
    
    MsgBox "去重完成", vbInformation
End Sub

关键修复点 #

1. 从最后一行往上遍历，删除行后不会打乱未遍历行的索引
2. 用Abs()计算Score差值，避免正负值干扰判断
3. 严格按照规则对比，删除不符合保留条件的行

注意事项 #

• 确保源数据表头为ID、Score、Peak，对应A、B、C列，否则需修改代码中的列索引
• 浮点数比较若遇精度问题（如0.0199999999被识别为0.02），可改用Round(scoreDiff, 2)保留两位小数后再判断

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