Question

我一直在摆弄这张纸比我应该的时间更长。这是停放在他们不应该的区域的汽车列表。经过6个月的时间，我试图让它们自动进入＆＃34;存档＆＃34;在另一张工作簿中。基本上我一直试图找到一个宏，以便在从列中的日期起6个月后，它将自动切割行并将其插入下一张纸。任何帮助将不胜感激。到目前为止，我已经为此工作了3天，我的大脑被炸了！显然我无法发布截图，因为我需要10的声誉（无论这意味着什么）我可以完全通过电子邮件发送它。

Sub Worksheet_Change(ByVal Target As Excel.Range)

    If Target.Column = 5 Then
        Application.EnableEvents = False
        If Target.Value = TODAY() - 180 Then
            Target.EntireRow.Copy
            Worksheets("Archive").Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            Target.EntireRow.Delete
            Application.EnableEvents = True

            Exit Sub
        End If
    End If



    If Target.Column <> 5 Then Exit Sub
    If Target.Row = 2 Then Exit Sub
    If Left(Target.Offset(0, -1), 1) = "~" Then Exit Sub
    If Left(Target.Offset(0, -1), 1) = "~" Then Exit Sub
    If Left(Target.Offset(0, -1), 1) = "=Row()-1" Then Exit Sub
    Target.Offset(0, -1).Formula = "=Row()-1"

End Sub

Answer 1

因为您的信息不够，因此我认为您的记录已按时间排序，时间位于A栏

Sub MoveRow()
Dim dRow, hRow As Double
Dim s1, s2 As Integer

dRow = 2
hRow = 2
'' number of sheet contain record
s1 = 1
'' num ber of sheet history
s2 = 2

Do While Sheets(s1).Cells(dRow, 1) <> Empty
    ' check if month difference is greater or equal 6
    If DateDiff("m", Sheets(s1).Cells(dRow, 1), Date) >= 6 Then
        Sheets(s1).Cells(dRow, 1).EntireRow.Cut Destination:=Sheets(s2).Cells(hRow, 1)
        Sheets(s1).Cells(dRow, 1).EntireRow.Delete
        hRow = hRow + 1
    Else
        ' if the record is near 6 months, the code will end // reduce time process
        Exit Do
    End If

Loop

MsgBox ("Done")

End Sub

6个月后将行移到另一张纸上

1 个答案: