Extract data from one sheet to another in the same workbook based on the date in a column

[YingFa]

Hello All,

Can I please have your help to know to extract data based on the date that is in a column? For example, I have a huge data set but I would like to extract based on the date in column B from 2016 (01/01/2016) to 2020 (01/01/202). Is this possible? The data I have goes from column A to column AM. Thank you.

 

[dave3009]

Hi, you can use advanced filter.

Somewhere on your sheet put the header of the column with date, below this put >=01/01/2016. Below that put <01/01/2020.

Goto Data tab>> Advanced
Choose copy to another location
List range = your data set
Criteria range = the three cells you just made
Copy to = where you want to send it to.

HTH
Dave

 

[JoeMo]

Here's a macro you can try if your data and layout meets the stated assumptions:

Sub ExtractData()
'assumes data begins in A1 of activesheet, no formulas in col B, dates in column B
'creates new sheet named 'Extract' for the extracted data which starts in A1 of Extract
Const StartDate As Date = #1/1/2016#  'Set start and end dates here
Const EndDate As Date = #1/1/2020#
Dim sourceSht As Worksheet, R As Range, Vdate As Variant, i As Long, Vtemp As Variant, Rout As Variant
Set sourceSht = ActiveSheet
Set R = sourceSht.Range("A1").CurrentRegion
Vdate = R.Columns(2).Value
ReDim Vtemp(1 To UBound(Vdate, 1), 1 To 1)
For i = 1 To UBound(Vdate, 1)
    If Vdate(i, 1) >= StartDate And Vdate(i, 1) <= EndDate Then
        Vtemp(i, 1) = "#N/A"
    Else
        Vtemp(i, 1) = Vdate(i, 1)
    End If
Next i
R.Columns(2).Value = Vtemp
On Error Resume Next
Set Rout = R.Columns(2).SpecialCells(xlCellTypeConstants, xlErrors).EntireRow
On Error GoTo 0
If IsEmpty(Rout) Then
    MsgBox "No dates in column B within the target range"
    Exit Sub
Else
    R.Columns(2).Value = Vdate
    On Error Resume Next
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    Sheets("Extract").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    Sheets.Add after:=ActiveSheet
    ActiveSheet.Name = "Extract"
End If
Rout.Copy Destination:=Sheets("Extract").Range("A1")
R.Columns(2).Value = Vdate
sourceSht.Select
Application.ScreenUpdating = True
End Sub