Copy the row that meet certain criteria to the bottom of my data

Question

I have the following question, for example, if i have the following data:

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

If I want that for every row for which the day is more than 45 days (> 45days), the entire row will be copy down to the next new row. So the result will be original data plus 3 more rows for which the date has been more than 45 days from today. (I need it be more dynamic). I can find some similar samples but was unable to modify it to suit my needs.

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

Code

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

Avoid the use of .Select INTERESTING READ

Now You can use Autofilter for this or you can use the method that I am using below.

Let's say your worksheet looks like this

Logic:

Loop through the cell in column A and use DateDiff to check if the date is greater than 45 or not.

Once we find the range, we don't copy it to the end in the loop but store it in temp range. We copy the range at the end of the code. This way, your code will run faster.

Code:

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

Output:

And if you want to show Expired in Col C then use this

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

Output:

EDIT (FOLLOWUP FROM COMMENTS)

Is this what you are trying?

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