修改VBA合并重复行求和子过程 实现A、B列匹配后汇总C、D列

需求说明 #

• 原有逻辑：检测到A列存在匹配值时，将匹配行合并为单行，同时对B、C列数值求和汇总至保留行
• 调整要求：仅当A、B两列的值同时匹配时才触发合并操作，合并后对C、D列的数值求和，最后删除重复行

效果示例 #

原始数据：

A  A  5  5 
A  A  5  5
A  B  6  1

处理后结果：

A  A  10 10
A  B  6  1

原有代码 #

Sub Consolidate()
     
   Application.ScreenUpdating = False
        
            Dim s As Worksheet, last_row As Long
            Dim row As Long
            Dim col As Integer, v, m
            
            Set s = Worksheets("Sheet12")
            s.Activate
            last_row = s.Cells(s.rows.Count, 1).End(xlUp).row 'find the last row with data
                
            For row = last_row To 3 Step -1
                v = s.Cells(row, "A").Value
                m = Application.Match(v, s.Columns("A"), 0) 'find first match to this row
                If m < row Then                             'earlier row?
                    'combine rows `row` and `m`
                    s.Cells(m, "B").Value = s.Cells(m, "B").Value + s.Cells(row, "B").Value
                    s.Cells(m, "C").Value = s.Cells(m, "C").Value + s.Cells(row, "C").Value
                    
                    s.rows(row).Delete
                End If 'matched a different row
            Next row
            
End Sub

修改后可用代码 #

Sub Consolidate()
     
   Application.ScreenUpdating = False
        
   Dim s As Worksheet, last_row As Long
   Dim row As Long
   Dim m As Variant, colA_val, colB_val
            
   Set s = Worksheets("Sheet12")
   s.Activate
   last_row = s.Cells(s.Rows.Count, 1).End(xlUp).Row '定位最后一行有数据的行号
                
   For row = last_row To 3 Step -1
       colA_val = s.Cells(row, "A").Value
       colB_val = s.Cells(row, "B").Value
       '查找A、B两列同时匹配的首行位置
       m = Evaluate("MATCH(1,(" & s.Columns("A").Address & "=""" & colA_val & """)*(" & s.Columns("B").Address & "=""" & colB_val & """),0)")
       
       If Not IsError(m) Then
           If m < row Then '存在更早的匹配行
               '汇总C、D列数值到首匹配行
               s.Cells(m, "C").Value = s.Cells(m, "C").Value + s.Cells(row, "C").Value
               s.Cells(m, "D").Value = s.Cells(m, "D").Value + s.Cells(row, "D").Value
               '删除当前重复行
               s.Rows(row).Delete
           End If
       End If
   Next row
   
   Application.ScreenUpdating = True
End Sub

核心修改点 #

• 匹配规则调整：原逻辑仅校验A列值，改为同时校验A、B两列值，两列值完全一致才判定为可合并的重复行
• 汇总字段调整：原逻辑对B、C列求和，改为对C、D列求和
• 补全屏幕更新恢复代码：原代码关闭屏幕更新后未重新开启，运行后容易出现表格操作卡顿的问题

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