Excel按单元格值合并重复行求和删冗余的VBA问题咨询

• 循环边界固定无动态更新：代码启动时就把最后一行行号b锁定为初始值，后续删除行后实际表格总行数持续减少，但循环始终用最初的b当遍历终点，最终会超出实际有效数据范围反复空转
• 行删除的偏移抵消逻辑完全失效：从前往后遍历删除行时，删掉第k行后，原本k+1位置的行会自动上移到k的位置，原代码靠手动执行k = k - 1抵消偏移，实际流程是删完行k减1，下一次内层循环执行Next k时k又自动加1，等于直接跳过了上移过来的待检查行；当k值减到小于j时，循环指针会反复在j和k之间横跳，永远无法抵达循环终点
• 单元格引用未绑定指定工作表：代码中直接使用Cells(j, 2)、Rows(k)时没有指定归属工作表，一旦过程运行时激活了其他工作表，会直接操作错对象，进一步打乱行计数逻辑
• 变量类型定义不合理：用Integer/Double类型存行号，数据行超过32767时会直接溢出报错，也容易因浮点类型的精度问题导致循环计数异常

采用字典分组的方案处理，比逐行删除的效率提升两个数量级，完全不存在循环偏移问题：

• 先按指定的匹配列值做分组，累计每组所有行的数值列总和
• 直接将分组结果按每组第一次出现的顺序写回工作表，无需逐行删除冗余行
• 支持自定义匹配列、求和列、起始处理行，适配不同的表格结构

完整可运行代码 #

Sub 按标识列合并重复行并求和()
    ' 可自定义配置项
    Const SHEET_NAME As String = "Sheet1"
    Const MATCH_COL As Integer = 2  ' 按哪一列的值判断重复（B列对应值为2）
    Const SUM_COL As Integer = 3    ' 对哪一列的数值做求和（C列对应值为3）
    Const START_ROW As Long = 1      ' 从第几行开始处理（有表头就改成2）
    
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim dict As Object
    Dim i As Long
    Dim keyVal As Variant, sumVal As Variant
    
    Set ws = ThisWorkbook.Worksheets(SHEET_NAME)
    lastRow = ws.Cells(ws.Rows.Count, MATCH_COL).End(xlUp).Row
    
    ' 初始化字典做分组存储
    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' 匹配时不区分大小写
    
    ' 遍历全表完成分组求和
    For i = START_ROW To lastRow
        keyVal = ws.Cells(i, MATCH_COL).Value
        sumVal = ws.Cells(i, SUM_COL).Value
        ' 跳过匹配列为空的无效行
        If keyVal <> "" Then
            If dict.Exists(keyVal) Then
                dict(keyVal) = dict(keyVal) + sumVal
            Else
                dict.Add keyVal, sumVal
            End If
        End If
    Next i
    
    ' 清空原数据区域，写入合并后的结果
    ws.Range(ws.Cells(START_ROW, 1), ws.Cells(lastRow, ws.UsedRange.Columns.Count)).ClearContents
    i = START_ROW
    ' 按第一次出现的顺序写回每组的结果
    For Each keyVal In dict.Keys
        ws.Cells(i, MATCH_COL).Value = keyVal
        ws.Cells(i, SUM_COL).Value = dict(keyVal)
        i = i + 1
    Next keyVal
    
    Set dict = Nothing
    Set ws = Nothing
    MsgBox "处理完成！共合并" & (lastRow - START_ROW + 1 - dict.Count) & "行冗余重复数据"
End Sub

如果不想改动原有代码的整体逻辑，只需要修正遍历思路，改成从下往上遍历删除——这种方向下，删除下面的行完全不会影响上面的行号，根本不需要手动抵消行偏移，从根源上避免死循环：

Sub 原逻辑修复版()
    Dim b As Long
    Dim y As Worksheet
    Dim j As Long, k As Long

    Set y = ThisWorkbook.Worksheets("Sheet1")
    b = y.Cells(y.Rows.Count, 2).End(xlUp).Row

    ' 从最后一行往上遍历
    For j = b To 1 Step -1
        ' 从当前行往上找和当前行标识相同的组首行
        For k = j - 1 To 1 Step -1
            If y.Cells(j, 2).Value = y.Cells(k, 2).Value Then
                ' 把当前行的数值累加到第一次出现的组首行
                y.Cells(k, 3).Value = y.Cells(k, 3).Value + y.Cells(j, 3).Value
                ' 删除当前的冗余重复行
                y.Rows(j).EntireRow.Delete
                ' 删完就跳出内层循环，避免重复匹配
                Exit For
            End If
        Next k
    Next j
End Sub

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