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