Vba to select rows based on date

[Wither125]

Hello,

I want to select the rows based on the date and past it in other sheet.

for ex: lets take today's date 24/06/2016. So now select the rows that is < 8 days and >8 days from 24/06/2016 on wards and paste it in the other sheet.

Below is pic.

Thank You!

Regards
Wither

 

[JLGWhiz]

This could probably be done faster with a filter, but this should work.

Sub eightaway()
Dim c As Range
    With ActiveSheet
        For Each c In .Range("B2", .Cells(Rows.Count, 2).End(xlUp))
            If c >= Date + 8 Or c < Date - 8 Then
                c.EntireRow.Copy Sheets(2).Cells(Rows.Count, 1).End(xlUp)(2)
            End If
        Next
    End With
End Sub

 

[Perpa]

Hello,

I want to select the rows based on the date and past it in other sheet.

for ex: lets take today's date 24/06/2016. So now select the rows that is < 8 days and >8 days from 24/06/2016 on wards and paste it in the other sheet.

Below is pic.

Thank You!

Regards
Wither

Just saw the previous post...ignore this if question answered.

Wither,
Assumes your data is on Sheet 1 and you want to copy data to Sheet 2 if the 'Effective_Date' falls outside the 16 days centered on the value in C1. Make sure to format your dates as numbers, not as text. If the date aligns to the left side of the cell it is text...if it aligns to the right then it is a number. Your date is a 'Custom' format: 'dd/mm/yyyy'
I provided a line to delete the copied rows from Sheet 1. Just uncomment, ie. remove the single quote at the beginning of that line (see line in red font below) if you want to delete those rows from Sheet 1.
Copy the subroutine into a module (Alt+F11 to open the VBE window, Paste, close the VBE window, and save as a macro-enabled workbook). You should probably do that in a copy of your workbook so you don't lose any data. Then press Alt+F8 and select ' CopyToSheet2', then press 'Run'.
Perpa

Sub CopyToSheet2()
Dim LastRow, Last2Row, rw As Long

LastRow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
With Sheets("Sheet1")
    For rw = LastRow To 2 Step -1
       If .Cells(rw, "B") < .Cells(1, "C") - 8 Or .Cells(rw, "B") > .Cells(1, "C") + 8 Then
            Last2Row = Sheets("Sheet2").UsedRange.Rows.Count + 1
            Sheets("Sheet2").Cells(Last2Row, "A") = .Cells(rw, "A")
            Sheets("Sheet2").Cells(Last2Row, "B") = .Cells(rw, "B")
            
            [COLOR="#FF0000"]'.Cells(rw, "B").EntireRow.Delete    'Uncomment this line if you want to delete the row from Sheet 1[/COLOR]
       End If
    Next rw
End With
End Sub

 

[Wither125]

Thank's for the reply u r code works !

 

[JLGWhiz]

Thank's for the reply u r code works !

Happy to assist,
Regards, JLG

 

[Perpa]

Thank's for the reply u r code works !

Glad it worked for you...Thank you for the 'LIKE' Whither.
Perpa