Datum wird bei erneuter Suche nicht gefunden
18.06.2025 22:36:16
Morris
ich habe nachfolgendes Probleme und verzweifle langsam.
Für berufliche Zwecke wollte ich eine Monatsplanung erstellen und habe hierfür einen Code in ein worksheet_change Ereignis geschrieben, das bei Ausführung weitere Arbeitblätter nach Datum sowie Namen durchsucht und eine Änderung in den jeweiligen AB vornimmt. So weit funktioniert alles bis auf die range.find Funktion. Es treibt mich in den Wahnsinn, da bei "Erstdurchlauf" des Ereignisses, das Suchdatum gefunden wird und hierüber ein Suchbereich festlegt, in welchem ein Name gefunden werden soll. Wie gesagt, erstes Datum kein Problem, beim zweiten ist der SuchBereich .find(SuchDatum) = nothing. Das Suchdatum ist mittels CDate als Datum deklariert und in der Variablendimension als date angegeben. Für das hoffentlich bessere Verständnis nachfolgender Code (und ich bin absoluter Laie in VBA)
Option Explicit
Dim letzteZeileNeu, ÄnderungSp, ÄnderungZ, Wochentag, Tag, Sp, Spalte, i As Byte
Dim DatumAlt, DatumNeu, Suche, Zwischen, SuchDatum, Datum As Date
Dim Ws As Worksheet
Dim Bereich, DatumBereich, NameBereich As Range
Dim Antwort, Änderung, SuchName, Suchfeld As String
Dim Wochenzahl, ErsteWoche, LetzteWoche As Double
Sub worksheet_change(ByVal Target As Excel.Range)
With Worksheets("Vorblatt")
Set Bereich = .UsedRange
If Not Application.Intersect(Target, Bereich) Is Nothing Then
'On Error GoTo NächsterBereich
For Each Bereich In Target.Cells
Änderung = Bereich.Address
ÄnderungSp = Bereich.Column
ÄnderungZ = Bereich.Row
'Prüfung Schichten im Zweiteilungsdienst
If ÄnderungSp = 6 Then
If .Cells(ÄnderungZ, ÄnderungSp).Value > "" Then
If .Cells(ÄnderungZ, ÄnderungSp).Value >= .Cells(1, 5).Value And .Cells(ÄnderungZ, ÄnderungSp).Value = DateSerial(Year(.[E1]), Month(.[E1]) + 1, Day(0)) Then
Worksheets("Liste").Cells(ÄnderungZ - 1, 22).Value = .Cells(ÄnderungZ, ÄnderungSp).Value
Wochenzahl = Application.WorksheetFunction.RoundUp((Weekday(.Range("E1").Value, vbMonday) + Day(.Cells(ÄnderungZ, ÄnderungSp).Value)) / 7, 0)
Suche = .Cells(ÄnderungZ, ÄnderungSp).Value
Set Bereich = Worksheets(Wochenzahl & ". Woche").UsedRange.Find(Suche, LookIn:=xlValue, lookat:=xlWhole)
ÄnderungSp = Bereich.Column
ÄnderungZ = Bereich.Row
If ÄnderungSp > 10 Then
If ÄnderungZ 79 Then
Sp = 3
Else
Sp = 2
End If
Worksheets(Wochenzahl & ". Woche").Cells(ÄnderungZ + 1, ÄnderungSp).Value = "TL"
Worksheets(Wochenzahl & ". Woche").Cells(ÄnderungZ + 1, ÄnderungSp + Sp).Value = ""
Worksheets(Wochenzahl & ". Woche").Cells(ÄnderungZ + 1, ÄnderungSp + Sp).Interior.Color = xlColorIndexNone
Worksheets(Wochenzahl & ". Woche").Cells(ÄnderungZ + 1, ÄnderungSp + (Sp * 2)).Value = "NL"
ElseIf ÄnderungSp 10 Then
Sp = 2
Worksheets(Wochenzahl & ". Woche").Cells(ÄnderungZ + 1, ÄnderungSp).Value = "TL"
Worksheets(Wochenzahl & ". Woche").Cells(ÄnderungZ + 1, ÄnderungSp + Sp).Value = ""
Worksheets(Wochenzahl & ". Woche").Cells(ÄnderungZ + 1, ÄnderungSp + Sp).Interior.Color = xlColorIndexNone
Worksheets(Wochenzahl & ". Woche").Cells(ÄnderungZ + 1, ÄnderungSp + (Sp * 2)).Value = "NL"
End If
Else
MsgBox ("Das eingegebene Datum liegt außerhalb des Planungsmonats. Bitte Eingabe prüfen.")
Exit Sub
End If
Else
Zwischen = Worksheets("Liste").Cells(ÄnderungZ - 1, 22).Value
If Zwischen .Cells(1, 5).Value Or Zwischen > DateSerial(Year(.[E1]), Month(.[E1]) + 1, Day(0)) Then
Exit Sub
End If
Wochenzahl = Application.WorksheetFunction.RoundUp((Weekday(.Range("E1").Value, vbMonday) + Day(Worksheets("Liste").Cells(ÄnderungZ - 1, 22).Value)) / 7, 0)
Set Bereich = Worksheets(Wochenzahl & ". Woche").UsedRange.Find(Zwischen)
ÄnderungSp = Bereich.Column
ÄnderungZ = Bereich.Row
If ÄnderungSp > 10 Then
If ÄnderungZ 79 Then
Sp = 3
Else
Sp = 2
End If
Worksheets(Wochenzahl & ". Woche").Cells(ÄnderungZ + 1, ÄnderungSp).Value = "F"
Worksheets(Wochenzahl & ". Woche").Cells(ÄnderungZ + 1, ÄnderungSp + Sp).Value = "S"
Worksheets(Wochenzahl & ". Woche").Cells(ÄnderungZ + 1, ÄnderungSp + Sp).Interior.Color = RGB(217, 217, 217)
Worksheets(Wochenzahl & ". Woche").Cells(ÄnderungZ + 1, ÄnderungSp + (Sp * 2)).Value = "N"
ElseIf ÄnderungSp 10 Then
Sp = 2
Worksheets(Wochenzahl & ". Woche").Cells(ÄnderungZ + 1, ÄnderungSp).Value = "F"
Worksheets(Wochenzahl & ". Woche").Cells(ÄnderungZ + 1, ÄnderungSp + Sp).Value = "S"
Worksheets(Wochenzahl & ". Woche").Cells(ÄnderungZ + 1, ÄnderungSp + Sp).Interior.Color = RGB(217, 217, 217)
Worksheets(Wochenzahl & ". Woche").Cells(ÄnderungZ + 1, ÄnderungSp + (Sp * 2)).Value = "N"
End If
End If
End If
'zweite Prüfung Personen im krank
If ÄnderungSp >= 1 And ÄnderungSp = 5 And ÄnderungZ > 1 Then
If .Cells(ÄnderungZ, 3) > "" And .Cells(ÄnderungZ, 4) > "" And .Cells(ÄnderungZ, 5) = "" Then
SuchDatum = CDate(.Cells(ÄnderungZ, 3).Value)
ErsteWoche = Application.WorksheetFunction.RoundUp((Weekday(.Range("E1").Value, vbMonday) + Day(.Cells(ÄnderungZ, 3).Value)) / 7, 0)
LetzteWoche = Application.WorksheetFunction.RoundUp((Weekday(.Range("E1").Value, vbMonday) + Day(.Cells(ÄnderungZ, 4).Value)) / 7, 0)
For i = ErsteWoche To LetzteWoche
NächstesDatum:
Set DatumBereich = Worksheets(i & ". Woche").UsedRange.Find(SuchDatum)
If DatumBereich Is Nothing Then
GoTo NächsteWoche
Else
If DatumBereich.Column = 3 Then
Spalte = 5
ElseIf DatumBereich.Column = 11 Then
Spalte = 8
Else: Spalte = 5
End If
Suchfeld = Cells(DatumBereich.Row + 3, DatumBereich.Column).Address & ":" & Cells(DatumBereich.Row + 37, DatumBereich.Column + Spalte).Address
SuchDatum = CDate(SuchDatum + 1)
SuchName = .Cells(ÄnderungZ, 1).Value
Set NameBereich = Worksheets(i & ". Woche").Range(Suchfeld).Find(SuchName, LookIn:=xlValues, lookat:=xlWhole)
If Not NameBereich Is Nothing Then
If Worksheets(i & ". Woche").Cells(NameBereich.Row, NameBereich.Column).MergeCells = True Then
Worksheets(i & ". Woche").Cells(NameBereich.Row, NameBereich.Column + 2).Value = .Cells(ÄnderungZ, 2).Value
Worksheets(i & ". Woche").Range(NameBereich.Address).Font.Strikethrough = True
Else
Worksheets(i & ". Woche").Cells(NameBereich.Row, NameBereich.Column + 1).Value = .Cells(ÄnderungZ, 2).Value
Worksheets(i & ". Woche").Range(NameBereich.Address).Font.Strikethrough = True
End If
End If
If SuchDatum > .Cells(ÄnderungZ, 4).Value And SuchDatum > .Cells(ÄnderungZ, 5).Value Then
GoTo NächsterBereich
Else
GoTo NächstesDatum
End If
End If
NächsteWoche:
Next i
ElseIf .Cells(ÄnderungZ, 3) > "" And .Cells(ÄnderungZ, 5) > "" Then
SuchDatum = CDate(.Cells(ÄnderungZ, 3).Value)
ErsteWoche = Application.WorksheetFunction.RoundUp((Weekday(.Range("E1").Value, vbMonday) + Day(.Cells(ÄnderungZ, 3).Value)) / 7, 0)
LetzteWoche = Application.WorksheetFunction.RoundUp((Weekday(.Range("E1").Value, vbMonday) + Day(.Cells(ÄnderungZ, 5).Value)) / 7, 0)
GoTo NächstesDatum
Else
GoTo NächsterBereich
End If
End If
'dritte Prüfung Personen Praktikant
' If ÄnderungSp = 7 Then
' If .Cells(ÄnderungZ, 7) > "" Then
' Suche = .Cells(ÄnderungZ, 7).Value
' Set Bereich = Worksheets("Liste").UsedRange.Find(Suche, LookIn:=xlValue, lookat:=xlWhole)
' Worksheets("Liste").Cells(Bereich.Row, 5).Value = "X"
' Worksheets("Vorblatt").Activate
' End If
' End If
NächsterBereich:
Next Bereich
End If
End With
End Sub
Ich habe die Datei 177798.xlsm etwas abgespeckt, da sich der Problemcode ausschließlich im worksheet_change Ereignis versteckt.
Was soll der Code tun?
Ändere ich im Vorblatt die Spalte 1-5, soll zunächst das Anfangsdatum (SuchDatum) in der Spalte 3 des Vorblatts in den Wochenarbeitsblättern gefunden werden, beginnend in der kalendarischen Woche, wo es stehen müsste. Wurde dies gefunden, soll geprüft werden, ob dort auch der in Spalte 1 eingegebene Name (SuchName) steht. Wenn ja, dann soll der Name durchgestrichen werden und in der Zelle rechts daneben der Eintrag aus Spalte 2 des Vorblatts stehen. Dann durchlaufe die Prozedur solange, bis das "Enddatum" aus Spalte 4 bzw. die "Verlängerung" aus Spalte 5 gefunden wurde.
Erstes Datum, macht der Code ohne Beanstandung, nächstes Datum (SuchDatum +1) nicht mehr. Set NameBereich = .find(Suchname)= nothing. Warum? Die Zellen sind als Datum im Format *dddd, dd. mmmm yyyy formatiert. Gleiches Problem besteht, wenn ich eine Änderung (bspw. ein Datum lösche und ein neues eingebe) vornehme. Ich hoffe ihr könnt weiterhelfen.
Danke für eure Rückmeldung
Gruß
Morris
Anzeige