Date Not Filtering Correctly

I've a very basic macro that performs some very quick tasks such as deleting rows, replacing a few characters and filtering by date, then moving columns across, leaving the cursor in cell A1, selecting the data left and copying it to the clipboard.

It's the date part that doesn't work 100% or indeed at all.

What it should do is only leave all data that is eighteen months old or less, with the most recent date at the top and the oldest at the bottom (this is how the data arrives prior to running the macro). I can't even tell you what dates it is selecting. It should be applying the filter based on all cells with a date in the same column (ending up as column 'D'). It almost suggests that it is not applying the date part at all. Any help would be very much appreciated.

Code:

---

Option Explicit
Sub Triage()
'
' Triage Macro
'
    Columns("A:A").Select
    Selection.Delete Shift:=xlToLeft
    Columns("B:B").Select
    Selection.Replace What:=" [O]", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Columns("D:D").Select
    Selection.NumberFormat = "dd/mm/yyyy;@"
    Columns("E:E").Select
    Selection.Delete Shift:=xlToLeft
    ActiveWindow.SmallScroll ToRight:=-1
    Rows("1:3").Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select
End Sub

---

Sorry, put the wrong code up and have now managed to sort it! :banghead:

Code:

---

Option Explicit
Sub Triage()
    '
    ' Triage Macro
    ' Perform the basic editing
    Columns("A:A").Select
    Selection.Delete Shift:=xlToLeft
    Columns("B:B").Select
    Selection.Replace What:=" [O]", Replacement:="", LookAt:=xlPart, _
                      SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                      ReplaceFormat:=False
    Columns("D:D").Select
    Selection.NumberFormat = "dd/mm/yyyy;@"
    Columns("E:E").Select
    Selection.Delete Shift:=xlToLeft
    ActiveWindow.SmallScroll ToRight:=-1
    Rows("1:3").Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select
   
    'Delete all rows with a date older than eighteen months
    Application.ScreenUpdating = False
    ActiveSheet.AutoFilterMode = False
    Dim FilterRange As Range, myDate As Date
    myDate = DateSerial(Year(Date) - 1, Month(Date) - 6, Day(Date))
    Set FilterRange = _
        Range("D8:D" & Cells(Rows.Count, 1).End(xlUp).Row)
    FilterRange.AutoFilter Field:=1, Criteria1:="<" & CDbl(myDate)
    On Error Resume Next
    With FilterRange
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(12).EntireRow.Delete
    End With
    Err.Clear
    Set FilterRange = Nothing
    ActiveSheet.AutoFilterMode = False
    Application.ScreenUpdating = True
   
    'Select all cells with data in them
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
   
    'Place selected text into the Clipboard
    Selection.Copy
   
End Sub

---

Having to open up this thread again as sometimes my code does not work as intended and delete rows that have a date older than eighteen months. It will occasionally leave rows that are older than eighteen months, sometimes by five years or more!

Is there something wrong with the code or is there perhaps a more efficient and effective method to achieve my aim?

Thanks!

Code:

---

ActiveSheet.AutoFilterMode = False
    Dim FilterRange As Range, myDate As Date
    myDate = DateSerial(Year(Date) - 1, Month(Date) - 6, Day(Date))
    Set FilterRange = _
        Range("D8:D" & Cells(Rows.Count, 1).End(xlUp).Row)
    FilterRange.AutoFilter Field:=1, Criteria1:="<" & CDbl(myDate)
    On Error Resume Next
    With FilterRange
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(12).EntireRow.Delete
    End With
    Err.Clear
    Set FilterRange = Nothing
    ActiveSheet.AutoFilterMode = False

---

Code:

---

Function Date_18MonthsAgo() As Date
    Date_18MonthsAgo = DateAdd("m", -18, Date)
End Function

---

Try filtering on "myDate" rather than a number [CDbl(myDate)]

Many thanks, Sam!

Having to put my "wally" head on now.

Would I add the function as is and then modifiy this line

Code:

---

FilterRange.AutoFilter Field:=1, Criteria1:="<" & CDbl(myDate)

---

to

Code:

---

FilterRange.AutoFilter Field:=1, Criteria1:="<" & Date_18MonthsAgo

---

Thanks!
Steve

Your code in msg#3 is working fine here.
Attach a worksheet where it's going to fail the way you describe.

Steve,
That works...If all you do is 18 months prior.

But maybe you work with different periods

Code:

---

Function Date_SomeMonthsAgo(NumMonthsPrior as Long) As Date
Dim NumPrior As Long
    NumPrior = NumMonthsPrior * -1
    Date_SomeMonthsAgo= DateAdd("m", NumPrior, Date)
End Function

---

Then you can use

Code:

---

X = Date_SomeMonthsAgo(18)
'OR
X = Date_SomeMonthsAgo(3)

---

However, if you need to work with very many dates, past and future, I would just use the VBA DateAdd Function as needed.

About the only time I see a need for a custom Dating UDF is for things like 30/60/90 day payment plans where Business Rules also require the due date be on a workday.

Quote:

---

Originally Posted by p45cal

Your code in msg#3 is working fine here.
Attach a worksheet where it's going to fail the way you describe.

---

I agree that this does work on occasions. Unfortunately by the time I have removed all the sensitive data I will end up with an eleven digit number column and the date column.

Quote:

---

Originally Posted by SamT

Steve,
That works...If all you do is 18 months prior.

But maybe you work with different periods

Code:

---

Function Date_SomeMonthsAgo(NumMonthsPrior as Long) As Date
Dim NumPrior As Long
    NumPrior = NumMonthsPrior * -1
    Date_SomeMonthsAgo= DateAdd("m", NumPrior, Date)
End Function

---

Then you can use

Code:

---

X = Date_SomeMonthsAgo(18)
'OR
X = Date_SomeMonthsAgo(3)

---

However, if you need to work with very many dates, past and future, I would just use the VBA DateAdd Function as needed.

About the only time I see a need for a custom Dating UDF is for things like 30/60/90 day payment plans where Business Rules also require the due date be on a workday.

---

I like the idea of being able to modify for future needs, so have tried incorporating your suggested code.

I've added as per the following as well as the UDF, but it now ignores all the date filter/delete row function and leaves the entire worksheet as it was including the rows that should have been deleted.

Code:

---

Dim D As Date

Range("$D:$D").NumberFormat = "dd/mm/yyyy"

D = Date_SomeMonthsAgo(18)
   
    Application.ScreenUpdating = False
    ActiveSheet.AutoFilterMode = False
    Dim FilterRange As Range
    Set FilterRange = _
        Range("D8:D" & Cells(Rows.Count, 1).End(xlUp).Row)
    FilterRange.AutoFilter Field:=1, Criteria1:="<" & D
    On Error Resume Next
    With FilterRange
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(12).EntireRow.Delete
    End With
    Err.Clear
    Set FilterRange = Nothing
    ActiveSheet.AutoFilterMode = False

---

I second: http://www.vbaexpress.com/forum/show...l=1#post409412

Just a column of dates will do. Just make sure that it's still 'not working' before attaching here.

Here is a sample spreadsheet with data that failed to locate / remove the lines from 2007. This is a really small sheet as usually there are hundreds on each.

Many thanks!
Steve

What's the point ?

Code:

---

Sub M_snb()
  With UsedRange.Columns(4)
        .AutoFilter 1, "<" & DateSerial(2018, 1, 1)
        .Offset(1).SpecialCells(12).ClearContents
        .AutoFilter
    End With
End Sub

---

This is your code with all the extras stripped out. Before running it, make sure that VBA Menu item: Tools >> Options >> General >> "Break on all Errors" is checked.

After running it, attach a file with Headers and an example row it failed on. Note for us any Errored lines in the code.

Code:

---

Option Explicit

Sub RemoveOutDated_BySamT()
Dim FilterRange As Range
   
    Set FilterRange = ActiveSheet.Range("D9:D" & Cells(Rows.Count, "A").End(xlUp).Row)
   
    With FilterRange
        .AutoFilter Field:=1, Criteria1:="<" & Date_SomeMonthsAgo(18)
        .SpecialCells(xlCellTypeVisible).EntireRow.Delete
    End With
   
    ActiveSheet.AutoFilterMode = False
End Sub

Function Date_SomeMonthsAgo(NumMonthsPrior As Long) As Date
Dim NumPrior As Long
    NumPrior = NumMonthsPrior * -1
    Date_SomeMonthsAgo = DateAdd("m", NumPrior, Date)
End Function

---

The first thing I notice with your file and your code is what happens when:
Set FilterRange = Range("D8:D" & Cells(Rows.Count, 1).End(xlUp).Row)
is executed. If I then manually:
FilterRange.Select
the selection in this pic is FilterRange:
Attachment 28482

then the following line of code filters:
Attachment 28483

So maybe it's what you're filtering, not the filtering itself, that's the problem?

In other code you've posted you have the top 3 rows of the sheet being deleted, so maybe you ought to adjust the 8 in
Set FilterRange = Range("D8:D" & Cells(Rows.Count, 1).End(xlUp).Row)
perhaps to 1?

If I do that I get a FlterRange of:
Attachment 28484

which when filtered looks like:
Attachment 28485

and when the rest is run:
Attachment 28486

which looks like the correct dates have been deleted.

ps. It's the last populated cell in column 1 (column A) that determines the range to filter because of the 1 in :
Set FilterRange = Range("D8:D" & Cells(Rows.Count, 1).End(xlUp).Row)

Firstly, a huge thankyou to all for looking into this for me. I've looked at each reply and think that p45cal has found out why the original code wasn't producing the desired results.

I have to put my hands up and acknowledge that I hadn't explained that the data source would have no headers or blank rows at the top. Sorry for this oversight on my part! :o:

I think that it was down to the data I was filtering rather than the code as suggested by p45cal and on his advice, I've now altered the Range to D1:D and so far, things are looking good! :thumb

Steve

Quote:

---

Originally Posted by HTSCF Fareha

the data source would have no headers or blank rows at the top

---

Autofilter expects a header row. If you have no header row either that top row will always be deleted or never be deleted depending on the code which deletes. Safest to make sure there is a header row (and it's safer if it's not a blank header).