VBA Code - Novice Here, Sorry!

[jaspr]

I have an Excel spreadsheet with dates in column B, starting row 6. The workbook has several different worksheets (tabs). Every time the spreadsheet is opened, I would like for a macro to look at all of the dates in column B (starting row 6) of every worksheet and automatically delete rows if the date is older than 1-year ago.

I have tried everything from a do loop to a dim statement, and I have been unsuccessful. Mostly, the code just repeats until every row I have is deleted. Any help would be much appreciated.

Thanks in advance!

[jonh]

Private Sub Workbook_Open()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
wsDeleteDateRows ws, 2, 6
Next
End Sub
Private Sub wsDeleteDateRows(ByRef ws As Worksheet, c As Byte, r As Long)
With ws
Do
If IsDate(.Cells(r, c)) Then
If CDate(.Cells(r, c)) < Date - 365 Then
ws.Rows(r).Delete Shift:=xlUp
Else
r = r + 1
End If
Else
Exit Do
End If
Loop
End With
End Sub

[Ago]

Private Sub Workbook_Open()

WS_Count = ActiveWorkbook.Worksheets.Count

For i = 1 To WS_Count
Sheets(i).Activate
LastRow = Range("B" & Rows.Count).End(xlUp).Row
FindValue = Format(Format(Date, "m/dd") & "/" & Format(Date, "yyyy") - 1, "dd/mmm/yyyy")
FindRow = Application.Match(CLng(CDate(FindValue)), Range("B6:B" & LastRow), 1) + 5


Rows("6:" & FindRow).EntireRow.Delete
Next i


End Sub



This handles leepyears too ;-)

[david000]

Private Sub Workbook_Open()
Dim i As Integer
Dim lr As Long
For i = 1 To ThisWorkbook.Sheets.Count
Sheets(i).Activate
Rows(6).Insert
Range("b6").Value = "Temp"
lr = Cells(Rows.Count, 2).End(xlUp).Row
With Range("b6").Resize(lr)
.AutoFilter Field:=1, Criteria1:="<" & DateAdd("yyyy", -1, Date), Operator:=xlAnd
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilter
End With
Rows(6).Delete
Next i
End Sub

[jaspr]

Thank you folks! These codes are works of art!

[Paul_Hossler]

I don't like to put a lot of processing code into the WB Open event (personal choice)

This I put into a standard module, and just have the WB Open call it

I assumed anything over 365 days is to be deleted (i.e. No Leap Years)




Option Explicit
Sub RemoveOldData()
Dim ws As Worksheet
Dim rBottomOfData As Range
Dim iRow As Long

Application.ScreenUpdating = False

For Each ws In ThisWorkbook.Worksheets
With ws
If .Range("B5").Value <> "DATE" Then GoTo GetNextRow

Set rBottomOfData = .Cells(.Rows.Count, 2).End(xlUp)

'when deleting, start from bottom and work your way up
For iRow = rBottomOfData.Row To 6 Step -1

Application.StatusBar = "Checking worksheet '" & .Name & "' Row Number = " & Format(iRow, "#,##0")


If Not IsDate(.Cells(iRow, 2).Value) Then GoTo GetNextRow

If CLng(Now) - CLng(.Cells(iRow, 2).Value) > 365 Then

'for testing
.Cells(iRow, 2).Interior.Color = vbRed

'for real
'commented out .Rows(iRow).Delete

End If

GetNextRow:
Next iRow

End With

Next
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub



Paul

[jaspr]

jonh,

I particularly liked the way your code worked. Can you tell me how you would add to it so that every time you opened the workbook, today's date autofilled in the first open cell, at the bottom of column B, in every worksheet? Thanks so much for your help.

[SamT]

Private Sub wsDeleteDateRows(ByRef ws As Worksheet, c As Byte, r As Long)
With ws
Do
If IsDate(.Cells(r, c)) Then
If CDate(.Cells(r, c)) < Date - 365 Then
ws.Rows(r).Delete Shift:=xlUp
Else
r = r + 1
End If
Else
Exit Do
End If
Loop
.Cells(Rows.Count, c).End(xlUp).Offset(1) = Date '<---------jaspr
End With
End Sub