优化相同ID单元格合并VBA代码，提升Excel数据处理速度

你的代码慢的核心原因是频繁的单元格读写操作和逐行删除行，这两个都是Excel VBA中效率极低的操作。以下是针对性的优化思路和完整代码：

核心优化方向 #

1. 用内存数组替代单元格直接操作 #

Excel对象模型（如Cells、Rows）的交互开销极大，把数据一次性读入VBA数组，在内存中完成合并逻辑，最后一次性写回工作表，能将速度提升几十倍。

2. 避免逐行删除，直接生成合并结果集 #

逐行删除会触发Excel内部的行结构调整，每删一行都要重新计算后续行的位置，几千行的情况下这个开销会被无限放大。直接在数组中筛选合并后的结果，最后批量写入，完全规避删除操作的损耗。

3. 变量类型修正与额外性能开关 #

• 将lngRow的类型从Integer改为Long，避免行号超过32767时溢出，同时Long在64位系统下运算更高效。
• 额外关闭Calculation和DisplayAlerts，即使工作表无计算任务，关闭计算也能避免Excel后台不必要的资源消耗。

优化后的完整代码 #

Sub MergeOptimized()
    Dim ws As Worksheet
    Dim sourceData As Variant, resultData As Variant
    Dim lastRow As Long, i As Long, resultRow As Long
    Dim columnToMatch As Long, columnToConcatenate As Long
    Dim currentID As String, currentText As String
    
    ' 指定目标工作表与列号（可替换为具体工作表，如ThisWorkbook.Sheets("Sheet1")）
    Set ws = ActiveSheet
    columnToMatch = 1
    columnToConcatenate = 3
    
    ' 开启性能优化开关
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    
    On Error GoTo Cleanup ' 确保异常时能恢复Excel设置
    
    ' 获取数据范围并读入内存数组
    lastRow = ws.Cells(ws.Rows.Count, columnToMatch).End(xlUp).Row
    sourceData = ws.Cells(1, 1).Resize(lastRow, ws.UsedRange.Columns.Count).Value
    
    ' 数据排序（若已预先排序，可注释此段）
    ws.Cells(columnToMatch).CurrentRegion.Sort Key1:=ws.Cells(columnToMatch), Header:=xlYes
    sourceData = ws.Cells(1, 1).Resize(lastRow, ws.UsedRange.Columns.Count).Value ' 排序后重新读入数组
    
    ' 初始化结果数组
    ReDim resultData(1 To UBound(sourceData, 1), 1 To UBound(sourceData, 2))
    resultRow = 1
    
    ' 遍历数组完成合并逻辑
    currentID = sourceData(2, columnToMatch) ' 跳过表头，从第2行开始
    currentText = sourceData(2, columnToConcatenate)
    
    For i = 3 To UBound(sourceData, 1)
        If sourceData(i, columnToMatch) = currentID Then
            ' 合并文本，添加换行符
            currentText = currentText & vbNewLine & sourceData(i, columnToConcatenate)
        Else
            ' 将当前合并结果写入结果数组
            resultData(resultRow, columnToMatch) = currentID
            resultData(resultRow, columnToConcatenate) = currentText
            ' 复制其他列数据（若不需要保留其他列，可删除此循环）
            Dim col As Long
            For col = 1 To UBound(sourceData, 2)
                If col <> columnToMatch And col <> columnToConcatenate Then
                    resultData(resultRow, col) = sourceData(i - 1, col)
                End If
            Next col
            resultRow = resultRow + 1
            ' 更新当前ID与文本
            currentID = sourceData(i, columnToMatch)
            currentText = sourceData(i, columnToConcatenate)
        End If
    Next i
    
    ' 写入最后一组合并数据
    resultData(resultRow, columnToMatch) = currentID
    resultData(resultRow, columnToConcatenate) = currentText
    For col = 1 To UBound(sourceData, 2)
        If col <> columnToMatch And col <> columnToConcatenate Then
            resultData(resultRow, col) = sourceData(UBound(sourceData, 1), col)
        End If
    Next col
    resultRow = resultRow + 1
    
    ' 清空原数据，写入合并结果
    ws.Cells(1, 1).Resize(lastRow, UBound(sourceData, 2)).ClearContents
    ws.Cells(1, 1).Resize(resultRow - 1, UBound(resultData, 2)).Value = resultData
    
Cleanup:
    ' 恢复Excel默认设置
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
    End With
    Set ws = Nothing
End Sub

额外说明 #

• 代码默认保留所有列的数据，若不需要保留合并列和匹配列之外的内容，可删除复制其他列的循环逻辑，进一步提升速度。
• 若数据已预先排序，可注释掉代码中的排序部分，减少一次数组读写的开销。
• 这种内存数组操作的方式，处理几万行数据都能在1秒内完成，3-4千行的场景下基本是瞬间完成。

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