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

to clarify, the format above deviated from the intended format. the format should be first row Alex 12/9/2013 (2 cells), second row John 11/30/2013 (2 cells), third row Irene 10/1/2013 (2 cells) and so on. — user3045580, Dec 10 '13 at 06:17
did you try anything on your own? with macro recorder or something? according to [this](http://mattgemmell.com/what-have-you-tried/)... — Kazimierz Jawor, Dec 10 '13 at 06:42
ya I did try by first recording, but i stuck with the if function process, I can sort out for the date that have been more than 45 days, but stuck in how to copy only the row that have been more than 45 days. Sorry i am newbie to excel macro but trying to simplify my daily work. — user3045580, Dec 10 '13 at 06:52
I have tried to recording a macro by first using IF function at the third column then use autofilter. However, when I add more data, the macro deviated, anyway to make it more dynamic? Also is there anyway to incorporate the IF function in the autofilter without having to test the condition first in the third column? Many thanks — user3045580, Dec 11 '13 at 01:58
Sorry to ask, how to make it structured as the one in grey background? — user3045580, Dec 11 '13 at 02:03
2 different cell (1 cell contains Alex the second cell is 12/9/2013) — user3045580, Dec 11 '13 at 04:12

score 1 · Accepted Answer · edited May 23 '17 at 12:12

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

enter image description here

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:

enter image description here

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:

enter image description here

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

hi it is useful, when i try to modify this macro according to my needed format but, mismatch error occur, you can get my example excel in this [link](http://wikisend.com/download/289368), can please advice? many thanks. @SiddharthRout — user3045580, Dec 11 '13 at 06:04
Thats a different sample :) Ok Do you want to check `End date - Invoice date > 45`? — Siddharth Rout, Dec 11 '13 at 06:09
i just need to check for end date only (invoice date is ignored) — user3045580, Dec 11 '13 at 06:11

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

1 Answers1