PDA

View Full Version : [SOLVED] Date Not Filtering Correctly



HTSCF Fareha
09-15-2020, 12:24 PM
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.


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

HTSCF Fareha
09-16-2020, 10:46 AM
Sorry, put the wrong code up and have now managed to sort it! :banghead:


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

HTSCF Fareha
05-14-2021, 02:15 PM
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!


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

SamT
05-14-2021, 03:20 PM
Function Date_18MonthsAgo() As Date
Date_18MonthsAgo = DateAdd("m", -18, Date)
End Function



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

HTSCF Fareha
05-15-2021, 03:33 AM
Many thanks, Sam!

Having to put my "wally" head on now.

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

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

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

Thanks!
Steve

p45cal
05-15-2021, 06:19 AM
Your code in msg#3 is working fine here.
Attach a worksheet where it's going to fail the way you describe.

SamT
05-15-2021, 08:20 AM
Steve,
That works...If all you do is 18 months prior.

But maybe you work with different periods
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
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.

HTSCF Fareha
05-16-2021, 12:20 AM
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.

HTSCF Fareha
05-16-2021, 12:33 AM
Steve,
That works...If all you do is 18 months prior.

But maybe you work with different periods
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
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.


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

snb
05-16-2021, 03:15 AM
I second: http://www.vbaexpress.com/forum/showthread.php?67835-Date-Not-Filtering-Correctly&p=409412&viewfull=1#post409412

p45cal
05-16-2021, 03:35 AM
Just a column of dates will do. Just make sure that it's still 'not working' before attaching here.

HTSCF Fareha
05-16-2021, 07:52 AM
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

snb
05-16-2021, 08:19 AM
What's the point ?


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

SamT
05-16-2021, 08:23 AM
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.

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

p45cal
05-16-2021, 08:58 AM
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:
28482

then the following line of code filters:
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:
28484

which when filtered looks like:
28485

and when the rest is run:
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)

HTSCF Fareha
05-17-2021, 12:01 AM
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

p45cal
05-17-2021, 02:39 AM
the data source would have no headers or blank rows at the topAutofilter 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).