Code automatisch ausführen lassen

[Tom 002]

Hallo miteinander,

ich habe vor einiger Zeit bereits eine Anfrage zu diesem Thema erstellt, bei der mir super geholfen wurde! An dieser Stelle noch einmal vielen Dank dafür!
Mein damaliges "Problem" ist aber leider noch nicht in Gänze gelöst und ich kann aufgrund meiner sehr geringen VBA-Kenntnisse trotz Google-Marathon leider
nicht selbst für Abhilfe sorgen. Aus diesem Grunde möchte ich Euch noch einmal um Unterstützung bitten:

Folgender Code soll dafür Sorge tragen, dass, sobald ein Datum in einer Zelle in Spalte "L" eingetragen wird, ein Eintrag in einer Zelle in Spalte "B" nach Ablauf von 40 Tagen gelöscht wird.
Beim jetzigen Code ist es so, dass dies funktioniert, wenn ich eine Datum eingebe das "Heute - 40 Tage" entspricht. Ich hätte es aber gern so, dass beim Öffnen der Liste geprüft wird, ob
in Spalte "L" Daten sind, die (basierend auf dem eingegebenen Datum) älter als 40 Tage sind und wenn ja, die jeweiligen Einträge in Spalte "B" gelöscht werden. Wenn in "L" keine Daten sind, soll nichts passieren.
Also einfach eine Automatisierung.
Hier ist der jetzige Code (dank an Schauan & Case!):

Option Explicit
Private Sub Worksheet_change(ByVal Target As Range)
    Dim rngRange As Range
    On Error GoTo Fin
    Application.EnableEvents = False
    If Not Intersect(Target, Columns("L")) Is Nothing Then
        For Each rngRange In Target
            If DateDiff("d", rngRange.Value, Date) > 40 And Trim(rngRange.Offset(, -10).Value) <> "" Then
                rngRange.Offset(, -10).Value = ""
            End If
        Next rngRange
    End If
Fin:    Application.EnableEvents = True
    If Err.Number <> 0 Then MsgBox "Error: " & Err.Number & " " & Err.Description
End Sub


Würde mich freuen, wenn jemand helfen kann!

Danke und beste Grüße
Tom

[Werner.M]

Hallo,

Tabellenblattname anpassen und Code ins Codemodul von "DieseArbeitsmappe" kopieren.

Code:

Option Explicit

Private Sub Workbook_Open()
Dim i As Long, raWeg As Range

On Error GoTo Fin
Application.EnableEvents = False

With Worksheets("Tabelle1")
    For i = 1 To .Cells(.Rows.Count, "L").End(xlUp).Row
        If .Cells(i, "L") <> "" Then
            If IsDate(.Cells(i, "L")) Then
                If DateDiff("d", .Cells(i, "L"), Date) > 40 And Trim(.Cells(i, "B")) <> "" Then
                    If raWeg Is Nothing Then
                        Set raWeg = .Cells(i, "B")
                    Else
                        Set raWeg = Union(raWeg, .Cells(i, "B"))
                    End If
                End If
            End If
        End If
    Next i
    If Not raWeg Is Nothing Then
        raWeg.ClearContents
    End If
End With

Set raWeg = Nothing
         
Fin:    Application.EnableEvents = True
If Err.Number <> 0 Then MsgBox "Error: " & Err.Number & " " & Err.Description
End Sub

Gruß Werner

[Tom 002]

Hallo Werner,

funktioniert einwandfrei! Super! Vielen Dank für die Hilfe!!!

Beste Grüße
Tom