Macro to copy Data where Date is > Today()

I recently just built a web based program, and before being able to create an account you have to enter your Date of Birth. The data is then stored in Excel...anyway long story short...I want to be able to copy all of the data that is in the Excel spreadsheet where the DOB > Today() to a new workbook. I have seen posts similar to this, I just can't find code that does exactly this. In my Excel spreadsheet the date is in column R, and I would need the data copied from cells A - R copied to a new workbook, where Date > Today(). Can someone help me with code that would complete this action?

You want to copy the row of data or the sheet's worth of data? Perhaps a mock workbook with mock data (non-sensitive data) showing the before and results of your requirements would be best as it would remove any guessing from the volunteers of this site.

I only want to copy the row of data that where the Date > Today(). The rest of the data can stay in the source workbook. Attached is a workbook with the same formatting, just filled with test data.

Perhaps this will get you close to what you want

Option Explicit

Sub GreaterThanToday()
    Dim NewWb As Workbook, CurrentWb As Workbook
    Dim WsTData As Worksheet, NewWs As Worksheet
    Dim Ocell As Range
    Dim GreaterThanExists As Boolean

    Set WsTData = Worksheets("Test_Data")
    Set CurrentWb = ThisWorkbook
    For Each Ocell In WsTData.Range(WsTData.Cells(2, 18), WsTData.Cells(Rows.Count, 18).End(xlUp))
        If Ocell.Value > Date Then
            Set NewWb = Workbooks.Add
            NewWb.Worksheets("Sheet1").Name = "NewWsName"
            Set NewWs = NewWb.Worksheets("NewWsName")
            NewWs.Rows(1).EntireRow.Cells.Value = WsTData.Rows(1).EntireRow.Cells.Value
            GreaterThanExists = True
            Exit For
        Else
            GreaterThanExists = False
        End If
    Next Ocell
    If GreaterThanExists = True Then
        For Each Ocell In WsTData.Range(WsTData.Cells(2, 18), WsTData.Cells(WsTData.Rows.Count, 18).End(xlUp))
            If Ocell.Value > Date Then
                NewWs.Cells(NewWs.Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.Cells.Value = Ocell.EntireRow.Cells.Value
            End If
        Next Ocell
    End If

End Sub

Awesome, that is almost exactly what I need. Two small tweak requests. One....when the code is executed, starting in row IW to the end of the workbook it will add #N/A. Is there a way to remove that portion of the code? Also, I think it would work better (this is totally my mistake, I'm sorry) if the data would be copied to a tab within the same workbook, not a new workbook....

I tried to tweak the code to copy to a worksheet within the same workbook, and I can't figure it out I tried the below code, and just commented out your code...

    Dim NewWb As Workbook
	Dim CurrentWb As Workbook
    Dim WsTData As Worksheet
    Dim	NewWs As Worksheet
    Dim Ocell As Range
    Dim GreaterThanExists As Boolean

    Set WsTData = Worksheets("Test_Data")
    Set CurrentWb = ThisWorkbook
    For Each Ocell In WsTData.Range(WsTData.Cells(2, 18), WsTData.Cells(Rows.Count, 18).End(xlUp))
        If Ocell.Value > Date Then
            'Set NewWb = Workbooks.Add
			Sheets.Add
			Sheets("Sheet2").Select
			Sheets("Sheet2").Name = ("Testing")
            'NewWb.Worksheets("Sheet1").Name = "NewWsName"
            'Set NewWs = NewWb.Worksheets("NewWsName")
	    Worksheets("Test_Data").Rows(1).EntireRow.Cells.Value = Worksheets("Testing").Rows(1).EntireRow.Cells.Value
            'NewWs.Rows(1).EntireRow.Cells.Value = WsTData.Rows(1).EntireRow.Cells.Value
            GreaterThanExists = True
            Exit For
        Else
            GreaterThanExists = False
        End If
    Next Ocell
    If GreaterThanExists = True Then
        For Each Ocell In WsTData.Range(WsTData.Cells(2, 18), WsTData.Cells(WsTData.Rows.Count, 18).End(xlUp))
            If Ocell.Value > Date Then
                NewWs.Cells(NewWs.Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.Cells.Value = Ocell.EntireRow.Cells.Value
            End If
        Next Ocell
    End If

I am getting an error object required:

    Set CurrentWb = ThisWorkbook
    For Each Ocell In WsTData.Range(WsTData.Cells(2, 18), WsTData.Cells(Rows.Count, 18).End(xlUp))
        If Ocell.Value >= Date Then
            'Set NewWb = Workbooks.Add
            'NewWb.Worksheets("Sheet1").Name = "NewWsName"
            'Set NewWs = NewWb.Worksheets("NewWsName")
            'NewWs.Rows(1).EntireRow.Cells.Value = WsTData.Rows(1).EntireRow.Cells.Value
            Sheets.Add
            Sheets("Sheet1").Select
            Sheets("Sheet1").Name = ("Testing")
            GreaterThanExists = True
            Exit For
        Else
            GreaterThanExists = False
        End If
    Next Ocell
    If GreaterThanExists = True Then
        For Each Ocell In WsTData.Range(WsTData.Cells(2, 18), WsTData.Cells(WsTData.Rows.Count, 18).End(xlUp))
            If Ocell.Value >= Date Then
                Sheets("Testing").Cells(Testing.Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.Cells.Value = Ocell.EntireRow.Cells.Value
                'NewWs.Cells(NewWs.Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.Cells.Value = Ocell.EntireRow.Cells.Value
            End If
        Next Ocell
    End If
End Sub

The line of code that it doesn't like is:

Sheets("Testing").Cells(Testing.Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.Cells.Value = Ocell.EntireRow.Cells.Value

You should try declaring a worksheet variable and using it for the worksheet "Testing". For example:

Dim NWs As Worksheet
Set NWs = Worksheets("Testing")

and then revise the loop using NWS, like:

NWs.Cells(NWs.Rows.Count,1).....

and so on.

Thanks for that tip, that worked perfectly! When I paste the data onto my new worksheet, how would I tell it to keep the source formatting? The header rows that it is copying are set to certain font's/font color, things like that, that I need to keep intact from worksheet to worksheet.

I tried this code:

            Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=False
            Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=False

But it did not work.