Clever-Excel-Forum

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

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

Hallo Werner,

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

Beste Grüße
Tom

Tom 002

Werner.M

Tom 002