AW: An alle die mir freundlicher Weise geholfen haben
07.12.2023 21:16:36
Piet
Hallo ihr beiden
ich habe zwei Fehler gefunden und den Code korrigiert. Über den Sprung nach Spalte J war ich selbst überrascht!
Nebeneffekt des Formel Copy Befehls! Vielleicht kann Willi ihn selbst auswechseln, sonst bitte ich Herbert Grom darum.
mfg Piet
Option Explicit 'Flughafen Statistik neu
Dim AC As Range, i As Integer
Dim TagDatum As Date, lz1 As Long
Const Pmax = 9 'max Personenzahl
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Ende 'ohne MsgBox Anzeige
If InStr(Target.Address, ":") Then Exit Sub
If Target.Value = Empty Then Exit Sub
On Error GoTo Fehler
'Bei Datum Eingabe Wochentag einfügen
If Target.Column = 1 Or Target.Column = 3 Or Target.Column = 4 Then
Application.EnableEvents = False
'Wochentag und Flughafen Code Formel einsetzen
TagDatum = Cells(Target.Row, 1)
Cells(Target.Row, 2) = Format(Day(TagDatum) - 2, "DDDD")
Range("J11").Copy 'Flughafen Formel kopieren
Cells(Target.Row, 10).PasteSpecial xlPasteFormulas
Application.CutCopyMode = False
Application.EnableEvents = True
If Target.Column = 1 Then Target.Offset(0, 2).Select _
Else Target.Offset(0, 1).Select
Exit Sub
End If
'Bei Personen_ Eingabe Buchungs Nummer prüfen
If Target.Column > 5 And Cells(Target.Row, 4) = Empty Then
Cells(Target.Row, 4).Select
MsgBox "Die Buchungs Nummer fehlt!" & vbLf & _
"Bitte zuerst die Buchungs Nummer einsetzen!", vbInformation: Exit Sub
End If
'Bei Personen Eingabe Buchungs Nummer prüfen
If Target.Column = 11 And Target > Pmax Then
MsgBox "Die max Personenzahl (" & Pmax & ") ist überschritten!" _
& vbLf & "Eingabe bitte korrigieren!", vbInformation
Target.Value = Empty: Target.Select: Exit Sub
End If
'Spalte P, Rückflug Datum Eingabe kopieren
If Target.Column = 16 Then
lz1 = Cells(Rows.Count, 1).End(xlUp).Row
For Each AC In Range("A11:A" & lz1)
If AC.Value = Target.Value Then
For i = 1 To 6
If AC.Cells(i, 1).Interior.ColorIndex > 1 Then _
MsgBox Target & " - Unzulässig, dieser Tag ist bereits voll belegt!", vbCritical: Exit Sub
'Eingabe in leere Zeile (Buchungsnummer leer)
If AC.Cells(i, 4) = Empty Then
Application.EnableEvents = False
'In Rückflug Datum Spalte A - E ausfüllen
AC.Cells(i, 3) = "'Reserviert" 'für Uhrzeit (Notiz)
AC.Cells(i, 1) = Target.Value 'Datum
AC.Cells(i, 3) = Target.Cells(1, 2) 'Uhrzeit
AC.Cells(i, 4) = Cells(Target.Row, 4) 'Buchungs Nr
AC.Cells(i, 5) = "Rückflug" 'Text einfügen
AC.Cells(i, 11) = Cells(Target.Row, 11) 'Personen
AC.Cells(i, 2) = Format(Day(Target), "DDDD") 'Wo-Tag
'Kunden Name, Text + Hinflug Datum als Platzhalter
AC.Cells(i, 19) = "Reserviert: " & Cells(Target.Row, 1)
'Rückflüge in Fettschrift
AC.Cells(i, 1).Resize(1, 5).Font.Bold = True
Application.EnableEvents = True
'Letzte Buchung Meldung, Tag ist voll!
If AC.Cells(i + 1, 1).Interior.ColorIndex > 1 Then _
MsgBox Target & " - letzte Buchung, dieser Tag ist jetzt voll belegt" _
& vbLf & vbLf & "Bitte noch Uhrzeit und Kunden Namen eingeben", vbInformation
Exit Sub
End If
Next i
End If
Next AC
MsgBox "Das Rückflug Datum fehlt - bitte manuell eintragen!", vbExclamation
End If
'Spalte S, Rückflug Uhrzeit und Kunden Name kopieren
If Target.Column = 17 Or Target.Column = 19 Then
'Prüfung ob Rückflug Datum vorhanden ist
If Target.Column = 19 And Cells(Target.Row, 17) = Empty Then
Target.Offset(0, -2).Select
MsgBox "Die Rückflug Uhrzeit fehlt!", vbInformation
End If
lz1 = Cells(Rows.Count, 1).End(xlUp).Row
For Each AC In Range("A11:A" & lz1)
If AC.Value = Cells(Target.Row, 16) Then
For i = 1 To 6
If AC.Cells(i, 1) = Cells(Target.Row, 16) And _
AC.Cells(i, 4) = Cells(Target.Row, 4) Then
Application.EnableEvents = False
AC.Cells(i, 3) = Cells(Target.Row, 17) 'Uhrzeit
AC.Cells(i, 19) = Cells(Target.Row, 19) 'Kunden Name
AC.Cells(i, 19).Font.Bold = True
Application.EnableEvents = True
Exit Sub
End If
Next i
End If
Next AC
MsgBox "Das Rückflug Datum fehlt - bitte manuell eintragen!", vbExclamation
End If
Exit Sub
Fehler: MsgBox "Unerwarteter Target Fehler"
Ende: Application.EnableEvents = True
End Sub