Filtering dates based on 11 months prior to current date and beyond.

[DanSMT]

Having an issue with this code. It doesn't appear to be collecting all dates based on the following statement;

11 months prior to today + all dates beyond that date.

I don't want to set a specific date because I want to be able to run the code any day.

-Thanks in advance for help!

Private Sub DUE1_Click()
Dim objWorkbook As Workbook
Dim dtStart As Date
Dim dtFinal As Date
    'open the workbook with data
    Set objWorkbook = Workbooks.Open( _
        "H:\RECORDS\MATRIX\matrix.xls")
    'filter dates
    dtStart = CDate(Evaluate("EOMONTH(TODAY(),-11)"))
    Sheets("Current Emp").Range("F6:BB300").AutoFilter 12, ">=" & dtStart
End Sub

 

[Mentor82]

Hi,
Check this out and let me know if that's what you need. I set the condition "If tmpDate >= dtStart" the way you did in your code.

Private Sub DUE1_Click()
Dim objWorkbook As Workbook
Dim dtStart As Date
Dim arr()
Dim counter&
Dim tmpDate As Date
Dim i&
Dim j&
Dim dateFound As Boolean
Dim lRow&

    'open the workbook with data
    Set objWorkbook = Workbooks.Open( _
        "H:\RECORDS\MATRIX\matrix.xls")
    'Filter dates
    dtStart = CDate(Evaluate("EOMONTH(TODAY(),-11)"))
    
    'Get array of the unique dates to filter
    For i = 7 To 300
        dateFound = False
        tmpDate = CDate(Cells(i, "Q"))
        If tmpDate >= dtStart Then 'change the condition if neccessary
            If counter = 0 Then
                counter = counter + 1
                ReDim Preserve arr(1 To counter)
                arr(counter) = tmpDate
            Else
                For j = 1 To UBound(arr)
                    If arr(1) = tmpDate Then
                        dateFound = True
                        Exit For
                    End If
                Next j
                
                If dateFound = False Then
                    counter = counter + 1
                    ReDim Preserve arr(1 To counter)
                    arr(counter) = tmpDate
                End If
            End If
        End If
    Next i
    
    Sheets("Current Emp").Range("$F$6:$BB$300").AutoFilter Field:=12, Operator:=xlFilterValues, Criteria1:=arr
    

End Sub

 

[DanSMT]

Finally got a chance to look at this.

Error out at;

tmpDate = CDate(Cells(i, "Q"))

 

[DanSMT]

I've modified some of the code, however when I click the button it just hides everything on the sheet. What I am trying to do is pull data from a large range of dates from this workbook to a new workbook. For instance: If a row has a date older then 11 months prior to the current date then I would like that entire row copied to a new workbook with the headers from row 1-5.

Private Sub DUE1_Click()
Dim objWorkbook As Workbook
Dim LstrDate As String
Dim dtStart As Date
Dim arr()
Dim counter&
Dim tmpDate As Date
Dim i&
Dim j&
Dim dateFound As Boolean
Dim lRow&

    'open the workbook with data
    Set objWorkbook = Workbooks.Open( _
        "H:\RECORDS\MATRIX\Matrix.xls")
    'Filter dates
    dtStart = DateAdd("m", -11, Date)
    
    'Get array of the unique dates to filter
    For i = 7 To 300
        dateFound = False
        LstrDate = DateAdd("m", -11, Date)
        tmpDate = CDate(LstrDate)
        If tmpDate >= dtStart Then
            If counter = 0 Then
                counter = counter + 1
                ReDim Preserve arr(1 To counter)
                arr(counter) = tmpDate
            Else
                For j = 1 To UBound(arr)
                    If arr(1) = tmpDate Then
                        dateFound = True
                        Exit For
                    End If
                Next j
    
                If dateFound = False Then
                    counter = counter + 1
                    ReDim Preserve arr(1 To counter)
                    arr(counter) = tmpDate
                End If
            End If
        End If
    Next i
    
    Sheets("Current Emp").Range("$F$6:$BB$300").AutoFilter Field:=12, Operator:=xlFilterValues, Criteria1:=arr
    

End Sub