How to delete sheet older than a month?

user_5881283 0
Viewed 102

I have to create weekly reports and send to different clients. I have a macro to copy required data for each client and give new sheet a name mmm-dd-yyyy (ex. Mar-01-2021).

I only want to keep last four weeks of sheets. I found code to delete any sheet older than one month but it does not work.

I have hidden sheets (Master and contact) which should stay as is. I might add Leadtime sheet in the future which will be visible to clients that should not be deleted.

Sub del_by_date2() 

Dim tagad As Date 
Dim pirms1 As Date 

tagad = Now() 
pirms1 = DateAdd("m", -1, tagad) 
test = Format(pirms1, "mmm-dd-yyyy") 

Application.DisplayAlerts = False 

For Each Worksheet In ThisWorkbook.Sheets 

If Right(Worksheet.Name, 4) < Right(test, 4) Then Worksheet.Delete
 
ElseIf Right(Worksheet.Name, 4) = Right(test, 4) _ And Left(Worksheet.Name, 2) <= Left(test, 2) 

Then 
Worksheet.Delete 
End If 

Next 

Application.DisplayAlerts = True 

End Sub
worksheet vba excel
2 Answers

Please give this a try and see if this works for you.

Sub del_by_date2()
Dim tagad   As Date
Dim pirms1  As Date
Dim WS      As Worksheet

Application.ScreenUpdating = False
Application.DisplayAlerts = False

tagad = Date
pirms1 = DateAdd("m", -1, tagad)

For Each WS In ThisWorkbook.Sheets
    If IsDate(WS.Name) Then
        If CDate(WS.Name) < pirms1 And WS.Visible = True Then WS.Delete
    End If
Next

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
user_23126140

Try,

Sub del_by_date2()
    Dim Ws      As Worksheet
    Dim vName() As String
    Dim DayBefore4W As Date
    Dim n As Long
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
   
    DayBefore4W = DateAdd("ww", -4, Date)
    
    For Each Ws In ThisWorkbook.Sheets
        If IsDate(Ws.Name) Then
            'If DateValue(Ws.Name) < DayBefore4W And Ws.Visible = True Then
            If CDate(Ws.Name) < DayBefore4W And Ws.Visible = True Then
                n = n + 1
                ReDim Preserve vName(1 To n)
                vName(n) = Ws.Name
            End If
        End If
    Next
    Debug.Print Join(vName, vbCrLf)
    If n Then
        Sheets(vName).Delete
    End If
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
user_81070920
Related