VBA excel makro - usuwanie wierszy, gdy data starsza niż podana

Question

Dzień dobry,

Proszę o pomoc w poprawieniu kodu tak, żeby po uruchomieniu usunął wiersze, w których występuje data wcześniejsza niż 2016-05-02 we wszystkich arkuszach (a nie tylko w arkuszu Sheet1 jak jest poniżej). W kolumnie A są daty. 

Poniższy kod znalazłam w sieci, sama niestety póki co jestem zupełnym laikiem.

Sub DeleteDateWithAutoFilter()

Dim MySheet As Worksheet, MyRange As Range
Dim LastRow As Long, LastCol As Long

'turn off alerts
Application.DisplayAlerts = False

'set references up-front
Set MySheet = ThisWorkbook.Worksheets("Sheet1")

'identify the last row in column A and the last col in row 1
'then assign a range to contain the full data "block"
With MySheet
    LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
    LastCol = .Range("A" & .Columns.Count).End(xlToLeft).Column
    Set MyRange = .Range(.Cells(1, 1), .Cells(LastRow, LastCol))
End With

'apply autofilter to the range showing only dates
'older than 2016-05-02, then deleting
'all the visible rows except the header
With MyRange
    .AutoFilter Field:=1, Criteria1:="<2016-05-02"
    .SpecialCells(xlCellTypeVisible).Offset(1, 0).Resize(.Rows.Count).Rows.Delete
End With

'turn off autofilter safely
With MySheet
    .AutoFilterMode = False
    If .FilterMode = True Then
        .ShowAllData
    End If
End With

'turn alerts back on
Application.DisplayAlerts = True

End Sub

 

Bardzo dziękuję za pomoc.
 

Answer 1

Witam,

najprościej będzie zamknąć ten kod, który znalazłaś w pętli for each po arkuszach(z małymi zmianami):

Dim MySheet As Worksheet, MyRange As Range
Dim LastRow As Long, LastCol As Long
 
'turn off alerts
Application.DisplayAlerts = False
For Each MySheet In ActiveWorkbook.Worksheets
'set references up-front
'Set MySheet = ThisWorkbook.Worksheets("Sheet1")
 
'identify the last row in column A and the last col in row 1
'then assign a range to contain the full data "block"
    With MySheet
        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
        Set MyRange = .Range("A1:A" & LastRow)
    End With
     
    'apply autofilter to the range showing only dates
    'older than 2016-05-02, then deleting
    'all the visible rows except the header
    With MyRange
        .AutoFilter Field:=1, Criteria1:="<2017-05-02"
        .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete' jesli kolumna A ma nagłówek
    End With

     
    'turn off autofilter safely
    With MySheet
        .AutoFilterMode = False
        If .FilterMode = True Then
            .ShowAllData
        End If
    End With
Next
'turn alerts back on
Application.DisplayAlerts = True
 
End Sub

Pozdrawiam

Comments

Bardzo dziękuję za pomoc! :)