Excel VBA对比两列日期对齐数据、按需插入行的实现问题

一、Power Query报错修复 #

你遇到的PQ报错核心原因是两张表均从同一个源Table11读取且未做列裁剪，导致两个表都携带Date 1列，关联后出现重复列名，同时你代码中调用的fnprevRow是自定义函数，未提前导入也会触发运行错误。修改后的无依赖可用代码如下：

let
// 替换Table11为你的实际表名
    Source = Excel.CurrentWorkbook(){[Name="Table11"]}[Content],
// 处理左侧A/B/C列，仅保留需要的字段
    TableA  = Table.TransformColumnTypes(Table.SelectColumns(Source,{"Date 1", "Value", "Value 2 (Src 1)"}),{{"Date 1", type date}, {"Value", type number}, {"Value 2 (Src 1)", type number}}),
// 处理右侧D/E列，仅保留需要的字段，彻底避免重名
    TableB  = Table.TransformColumnTypes(Table.SelectColumns(Source,{"Date 2", "Value 2 (Src 2)"}),{{"Date 2", type date}, {"Value 2 (Src 2)", type number}}),
// 按日期做全外连接
    join = Table.Join(TableA,"Date 1",TableB,"Date 2", JoinKind.FullOuter),
// 按日期排序直接实现对齐效果，不需要额外索引辅助
    #"Sorted Rows" = Table.Sort(join,{{"Date 1", Order.Ascending}, {"Date 2", Order.Ascending}}),
// 可选：新增统一对齐日期列，空值自动补全
    #"新增对齐日期" = Table.AddColumn(#"Sorted Rows", "对齐后日期", each if [Date 1] = null then [Date 2] else [Date 1])
in
    #"新增对齐日期"

二、VBA代码修改方案 #

你原有VBA的核心问题是：循环逻辑为从上到下，插入行后行索引错位、会跳过新行，且整行粘贴会覆盖另一组数据，32位Excel操作整行插入易触发兼容报错。修改后的代码如下：

Sub 对齐双源日期()
    Dim i As Long, lastRow As Long
    ' 关闭屏幕更新提速，避免卡顿
    Application.ScreenUpdating = False
    ' 取A、D列的最大行号，避免漏行
    lastRow = WorksheetFunction.Max(Cells(Rows.Count, "A").End(xlUp).Row, Cells(Rows.Count, "D").End(xlUp).Row)
    
    ' 采用从下往上循环，插入行不会影响未处理行的索引，不需要动态更新行号
    For i = lastRow To 2 Step -1
        ' 跳过空行
        If Not IsEmpty(Cells(i, "A")) And Not IsEmpty(Cells(i, "D")) Then
            Dim dateA As Date, dateD As Date
            dateA = Cells(i, "A").Value
            dateD = Cells(i, "D").Value
            
            If dateA < dateD Then
                ' A日期更小，当前行下方插入空行，将原D/E列下移
                Rows(i + 1).Insert Shift:=xlShiftDown
                Cells(i + 1, "D").Resize(1, 2).Value = Cells(i, "D").Resize(1, 2).Value
                Cells(i, "D").Resize(1, 2).ClearContents
            ElseIf dateA > dateD Then
                ' A日期更大，当前行上方插入空行，将原A/B/C列上移
                Rows(i).Insert Shift:=xlShiftDown
                Cells(i, "A").Resize(1, 3).Value = Cells(i + 1, "A").Resize(1, 3).Value
                Cells(i + 1, "A").Resize(1, 3).ClearContents
            Else
                ' 日期匹配的原有逻辑保留
                With Cells(i, "F")
                    .Value = "Yes"
                    .Interior.Color = RGB(198, 239, 206)
                    .Font.Color = RGB(0, 97, 0)
                End With
            End If
        End If
    Next i
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
End Sub

以上代码采用数组赋值替代复制粘贴，运行效率更高，也规避了32位Excel的整行操作兼容问题。

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