将符合特定条件的行复制到数据底部

Question

我有以下问题，例如，如果我有以下数据：

Alex 12/9/2013
John 11/30/2013
Irene 10/1/2013
Eve 9/9/2013
Max 1//30/2014
Stanley 1/1/2013

如果我想要那天超过45天（> 45天）的每一行，整个行将被复制到下一个新行。因此，结果将是原始数据加上3行，其日期已超过45天。 （我需要它更有活力）。我可以找到一些类似的样品，但无法根据我的需要进行修改。

Alex 12/9/2013
John 11/30/2013
Irene 10/1/2013
Eve 9/9/2013
Max 1//30/2014
Stanley 1/1/2013
Irene 10/1/2013 Expired
Eve 9/9/2013 Expired
Stanley 1/1/2013 Expired

代码

Sub Macro7()
    Range("A1:C1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$C$7").AutoFilter Field:=3, Criteria1:="yes"
    Range("A4:B7").Select
    Selection.Copy
    Range("A8").Select
    ActiveSheet.Paste
    ActiveSheet.Range("$A$1:$C$10").AutoFilter Field:=3
    Application.CutCopyMode = False
    Selection.AutoFilter
    Range("C1").Select
    Selection.End(xlDown).Select
    Range("C8").Select
    ActiveCell.FormulaR1C1 = "Expired"
    Range("C8").Select
    Selection.Copy
    Range("B8").Select
    Selection.End(xlDown).Select
    Range("C10").Select
    ActiveSheet.Paste
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
    Range("C11").Select
End Sub

Answer 1

避免使用.Select INTERESTING READ

现在您可以使用Autofilter，或者您可以使用我在下面使用的方法。

假设您的工作表看起来像这样

<强>逻辑：

循环显示A列中的单元格，并使用DateDiff检查日期是否大于45。

一旦我们找到了范围，我们就不会将它复制到循环的末尾，而是将其存储在临时范围内。我们复制代码末尾的范围。这样，您的代码将运行得更快。

<强>代码：

Option Explicit

Sub Sample()
    Dim ws As Worksheet
    Dim lRow As Long, i As Long, OutputRow As Long
    Dim copyRng As Range

    '~~> Change this to the relevant worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1")

    With ws
        '~~> Get LatRow in Col A
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row
        OutputRow = lRow + 1

        '~~> Loop through the cells
        For i = 1 To lRow
            If DateDiff("d", .Range("B" & i).Value, Date) > 45 Then
                If copyRng Is Nothing Then
                    Set copyRng = .Range("A" & i & ":B" & i)
                Else
                    Set copyRng = Union(copyRng, .Range("A" & i & ":B" & i))
                End If
            End If
        Next i

        '~~> Copy the expired records in one go
        If Not copyRng Is Nothing Then copyRng.Copy .Range("A" & OutputRow)
    End With
End Sub

<强>输出：

如果您想在Col Expired中显示C，请使用此

Option Explicit

Sub Sample()
    Dim ws As Worksheet
    Dim lRow As Long, i As Long, OutputRow As Long
    Dim copyRng As Range

    '~~> Change this to the relevant worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1")

    With ws
        '~~> Get LatRow in Col A
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row
        OutputRow = lRow + 1

        '~~> Loop through the cells
        For i = 1 To lRow
            If DateDiff("d", .Range("B" & i).Value, Date) > 45 Then
                If copyRng Is Nothing Then
                    Set copyRng = .Range("A" & i & ":B" & i)
                Else
                    Set copyRng = Union(copyRng, .Range("A" & i & ":B" & i))
                End If
            End If
        Next i

        '~~> Copy the expired records in one go
        If Not copyRng Is Nothing Then
            copyRng.Copy .Range("A" & OutputRow)

            lRow = .Range("A" & .Rows.Count).End(xlUp).Row

            .Range("C" & OutputRow & ":C" & lRow).Value = "Expired"
        End If
    End With
End Sub

<强>输出：

编辑（从评论中跟进）

这是你在尝试的吗？

Option Explicit

Sub Sample()
    Dim ws As Worksheet
    Dim lRow As Long, i As Long, OutputRow As Long
    Dim copyRng As Range

    '~~> Change this to the relevant worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1")

    With ws
        '~~> Get LatRow in Col B
        lRow = .Range("B" & .Rows.Count).End(xlUp).Row
        OutputRow = lRow + 1

        '~~> Loop through the cells
        For i = 15 To lRow
            If DateDiff("d", .Range("E" & i).Value, Date) > 45 Then
                If copyRng Is Nothing Then
                    Set copyRng = .Range("B" & i & ":I" & i)
                Else
                    Set copyRng = Union(copyRng, .Range("B" & i & ":I" & i))
                End If
            End If
        Next i

        '~~> Copy the expired records in one go
        If Not copyRng Is Nothing Then
            copyRng.Copy .Range("B" & OutputRow)

            lRow = .Range("B" & .Rows.Count).End(xlUp).Row

            .Range("I" & OutputRow & ":I" & lRow).Value = "Expired"
        End If
    End With
End Sub