Excel VBA需求：同ID末行空白单元格填充前序同ID非空值

Excel表格存在多行同ID数据，例如ID为"1"的行有3行，其中Rows("5:5")是该ID的末行，E5:F5为空白单元格，需将其填充为该ID前序行中最近的非空对应值；若前序对应值也为空，则继续向上查找同ID行。ID为"2"的行仅有1行时，需保持原样（即便存在空白）。

当前采用以下繁琐步骤，耗时且易导致Excel卡顿：

• 插入辅助列并填充1至最后一行的序列号；
• 按A列xlAscending、辅助列xlDescending排序；
• 合并同ID行的对应单元格；
• 取消所有单元格合并；
• 用宏删除空白行；
• 删除辅助列。

说明：实际数据集的表头为前两行。

插入辅助列并添加序列号 #

Sub Inser_Column_and_Add_SerialNumber()
   Dim ws As Worksheet: Set ws = ActiveSheet
   Dim LastRow As Long, Count As Long, arr, arrA, i As Long
   LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    Count = 1
    arr = ws.Range("A3:A" & LastRow).Value
    arrA = ws.Range("A3:A" & LastRow).Value
    For i = 1 To UBound(arr)
        If arr(i, 1) <> "" Then arrA(i, 1) = Count:  Count = Count + 1
    Next i
    ws.Range("B3").Resize(UBound(arrA), 1).Value = arrA
End Sub

合并同ID行对应单元格 #

Sub Merge_corresponding_Cell_on_Similar_Rows()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual

    Dim ws As Worksheet:  Set ws = ActiveSheet
    
    If ws.AutoFilterMode Then
       ws.AutoFilter.ShowAllData        'Clear any Filter
    Else
       ws.Rows("2:2").AutoFilter
    End If
       
    ws.Sort.SortFields.Clear            'Clear any previous sorting

    ws.AutoFilter.Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ws.AutoFilter.Sort.SortFields.Add Key:=Range("B1"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    ws.AutoFilter.Sort.Apply

    Dim LastRow As Long, lastCol As Long, arrWork, i As Long, j As Long, k As Long

    LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
     
    arrWork = ws.Range("A2:A" & LastRow).Value2
    
    For i = 1 To UBound(arrWork) - 1
    
        If arrWork(i, 1) = arrWork(i + 1, 1) Then        'Determine how many consecutive similar rows exist
                                            
            For k = 1 To LastRow
                If i + k + 1 >= UBound(arrWork) Then Exit For
                If arrWork(i, 1) <> arrWork(i + k + 1, 1) Then Exit For
            Next k
            
            For j = 1 To lastCol
                ws.Range(ws.Cells(i, j), ws.Cells(i + k, j)).Merge 'merge all the necessary cells based on previously determined k
           Next j
           
       End If
       
    Next i

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
End Sub

现寻求更高效的VBA解决方案，替代上述耗时易卡顿的操作。

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