Soru Eski Tarihli Satırları Sildirmek

[leonadies]

Değerli Üstatlar;

Bir excel dosyam var D: D satırında da tarihler mevcut. Bu excelde Bugünün tarihini dikkate alarak geriye dönük 120 gün önceki satırları silmek istiyorum. Geçmişteki 1-2 günlük şaşmalar önemli değil.(Yani 118-119-120-121 gün olur önemli değil). Her gün bu butona basarak excelimin şişmesini önleme amacındayım.

Makro ile yapabilir miyiz? Dosyam Ekte.

 

[Muzaffer Ali]

Merhaba.

Aşağıdaki kodu deneyin.

Sub Sil()
    Dim Bak As Long
    For Bak = Cells(Rows.Count, "D").End(xlUp).Row To 2 Step -1
        If IsDate(Cells(Bak, "D")) Then
            If Cells(Bak, "D") < Now - 120 Then
                Rows(Bak).Delete
            End If
        Else
            MsgBox Cells(Bak, "D").Address & " hücresindeki değer tarih değil."
        End If
    Next
    MsgBox "İşlem tammalandı."
End Sub

 

[kulomer46]

Merhaba

Alternatif olarak Ek 'li dosyayı ekliyorum.

Selamlar...

 

[Korhan Ayhan]

Alternatif;

Hız olarak avantaj sağlayabilir.

Option Explicit

Sub Sil()
    Dim Alan As Range, Veri As Variant, Son As Long, X As Long, Zaman As Double
   
    Zaman = Timer
   
    Application.ScreenUpdating = False
   
    Son = Cells(Rows.Count, "D").End(3).Row
    If Son = 2 Then Son = 3
   
    Veri = Range("D2:D" & Son).Value
   
    For X = LBound(Veri) To UBound(Veri)
        If Veri(X, 1) < Now - 120 Then
            If Alan Is Nothing Then
                Set Alan = Cells(X + 1, "D")
            Else
                Set Alan = Union(Alan, Cells(X + 1, "D"))
            End If
        End If
    Next
   
    If Not Alan Is Nothing Then
        Alan.EntireRow.Delete
        Set Alan = Nothing
        Application.ScreenUpdating = True
        MsgBox "120 günden eski kayıtlar silinmiştir." & Chr(10) & Chr(10) & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
    Else
        Application.ScreenUpdating = True
        MsgBox "Silinecek kayıt bulunamadı!", vbExclamation
    End If
End Sub

 

[leonadies]

Herkese teşekkür ederim Hepsi çalışıyor