优化动态区域单元格检查速度 改进Excel重复单元格合并宏

你需要优化现有VBA宏的运行速度，同时替换固定范围（比如A2:A2000）为动态范围，宏的功能是合并指定列中值相同的连续单元格。原宏代码如下：

Sub Merge_Duplicated_Cells()
'
Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim ws As Worksheet
Dim Cell As Range
    
' Merge Duplicated Cells

    Application.DisplayAlerts = False
    
    Sheets("1").Select
    Set myrange = Range("A2:A2000, B2:B2000, L2:L2000, M2:M2000, N2:N2000, O2:O2000")
    
CheckAgain:
    For Each Cell In myrange
        If Cell.Value = Cell.Offset(1, 0).Value And Not IsEmpty(Cell) Then
            Range(Cell, Cell.Offset(1, 0)).Merge
            Cell.VerticalAlignment = xlCenter
            GoTo CheckAgain
        End If
    Next

    Sheets("2").Select
    Set myrange = Range("A2:A2000, B2:B2000, L2:L2000, M2:M2000, N2:N2000, O2:O2000")

    For Each Cell In myrange
        If Cell.Value = Cell.Offset(1, 0).Value And Not IsEmpty(Cell) Then
            Range(Cell, Cell.Offset(1, 0)).Merge
            Cell.VerticalAlignment = xlCenter
            GoTo CheckAgain
        End If
    Next
    
    ActiveWorkbook.Save

    MsgBox "Report is ready"
    
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

优化要点 #

1. 替换固定范围为动态范围 #

不再硬编码行数，通过Cells(Rows.Count, 列号).End(xlUp).Row获取每列最后一个非空单元格的行号，自动适配数据行数变化。

2. 大幅提升运行速度 #

• 移除Select/Activate操作，直接通过工作表对象操作，减少界面交互开销
• 删掉低效的GoTo CheckAgain逻辑，改为批量识别连续重复值后一次性合并，避免反复从头遍历
• 封装重复的合并逻辑为循环处理，减少代码冗余，方便维护
• 统一设置应用级别的优化属性（关闭屏幕刷新、警告提示、事件触发），避免重复设置

优化后的完整代码 #

Sub Optimized_Merge_Duplicated_Cells()
    ' 开启应用级优化
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Dim targetSheets As Variant
    Dim targetCols As Variant
    Dim ws As Worksheet
    Dim col As Variant
    Dim lastRow As Long
    Dim startCell As Range
    Dim currentCell As Range

    ' 指定要处理的工作表和列
    targetSheets = Array("1", "2")
    targetCols = Array("A", "B", "L", "M", "N", "O")

    ' 遍历每个目标工作表
    For Each ws In ThisWorkbook.Sheets(targetSheets)
        ' 遍历每个目标列
        For Each col In targetCols
            ' 获取当前列最后一个非空单元格的行号
            lastRow = ws.Cells(ws.Rows.Count, col).End(xlUp).Row
            ' 从第二行开始处理（跳过表头）
            If lastRow >= 2 Then
                Set startCell = ws.Cells(2, col)
                Set currentCell = startCell

                ' 遍历当前列的单元格，识别连续重复值
                Do While currentCell.Row < lastRow
                    ' 如果当前单元格和下一个单元格值相同且非空
                    If currentCell.Value = currentCell.Offset(1, 0).Value And Not IsEmpty(currentCell.Value) Then
                        ' 继续向后找连续相同的单元格
                        Do While currentCell.Row < lastRow And currentCell.Value = currentCell.Offset(1, 0).Value
                            Set currentCell = currentCell.Offset(1, 0)
                        Loop
                        ' 合并从startCell到currentCell的范围
                        ws.Range(startCell, currentCell).Merge
                        ' 设置垂直居中
                        ws.Range(startCell, currentCell).VerticalAlignment = xlCenter
                    End If
                    ' 移动到下一个起始单元格
                    Set startCell = currentCell.Offset(1, 0)
                    Set currentCell = startCell
                Loop
            End If
        Next col
    Next ws

    ' 保存工作簿并提示完成
    ThisWorkbook.Save
    MsgBox "Report is ready"

    ' 恢复应用设置
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

内容的提问来源于stack exchange，提问作者Khaled Mohamed Rashed