查找B列相同值的最末记录，如果日期不等于当前日期则插入记录，并复制上一条记录。

buzhenglin

汉唐 发表于 2023-1-12 14:41
将
Do
……

在您的帮助下，终于完成，再次感谢您！！！
1、原表中两列日期的公式全部删除啦。
2、通过代码自动增加记录时，将两列日期按原来的公式写入了代码中。
3、实现了表中任何借款人，只要有一条完整记录，其他全部自动增加到当前日期。
4、全程自动化的感谢很爽，衷心感谢汉唐，您太牛了。
现贴出代码，给如有需要的朋友。
Sub TEST()
    Dim i As Long, j As Long, r As Long, n As Long
    Dim s, t
    Set d = CreateObject("scripting.dictionary")
    Do
        n = 0
        r = Cells(Rows.Count, 2).End(xlUp).Row
        If r < 3 Then Exit Sub
        For i = 3 To r
            s = Cells(i, 2).Value
            d(s) = i
        Next
        t = d.items
        For i = UBound(t) To 0 Step -1
            If Cells(t(i), 5).Value < Date Then
                n = t(i) + 1
                Cells(n, 1).Resize(1, 11).Insert xlShiftDown
                Cells(n - 1, 1).Resize(1, 11).Copy Cells(n, 1)
                Cells(n, 4) = DateAdd("m", 1, Cells(n - 1, 4))
                If DateAdd("m", 1, Cells(n, 4)) <= Date Then
                    Cells(n, 5) = DateAdd("m", 1, Cells(n, 4)) - 1
                Else
                    Cells(n, 5) = Date
                End If
                d(Cells(n, 2).Value) = n
            End If
        Next
    Loop Until Cells(n, 5) = Date
    Set d = Nothing
End Sub