AW: Neuer Termin ablegen und speichern
28.05.2020 11:49:07
UweD
Hi
Ok. Ich dachte, es müssten immer alle 8 Felder gefüllt sein.
Jetzt wird B25:G25 gelöscht, wenn alle diese 6 gefüllt sind
und D27; G27 ,wenn Datum und Zeit eingetragen sind.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim TB As Worksheet, Kunu, Datum, Zeit, Zeile As Long
Dim SpK As Integer, SpD As Integer, SpR As Integer
Dim RNG1 As Range, RNG2 As Range
On Error GoTo Fehler
Const APPNAME = "Worksheet_Change"
Set TB = Sheets("Datenbank")
SpK = 4 'Spalte der Kundennummer =D
SpD = 14 'Spalte mit Datum =N
SpR = 8 'Spalte mit Restdaten =H
Set RNG1 = Range("B25:G25")
Set RNG2 = Range("D27,G27")
'nur bei Änderungen in diesen Zellen auslösen
If Not Intersect(Union(RNG1, RNG2), Target) Is Nothing Then
Kunu = Range("B3")
If WorksheetFunction.CountIf(TB.Columns(SpK), Kunu) > 0 Then
'Kunde bereits vorhanden?
Zeile = WorksheetFunction.Match(Kunu, TB.Columns(SpK), 0)
Else
'Kunde nicht vorhanden?
MsgBox "Kundennummer nicht gefunden"
Exit Sub
End If
If Not Intersect(RNG1, Target) Is Nothing Then
'Restdaten eintragen
TB.Cells(Zeile, SpR).Offset(0, Target.Column - 2) = Target
'reset, wenn alle Zellen gefüllt
If WorksheetFunction.CountA(RNG1) = RNG1.Count Then
Application.EnableEvents = False
RNG1 = ClearContents
Application.EnableEvents = True
MsgBox "Erledigt"
End If
End If
If Not Intersect(RNG2, Target) Is Nothing Then
Datum = Range("D27")
Zeit = Range("G27")
'Datum / Zeit; Beides muss eingetragen sein
If IsDate(Datum) And IsNumeric(Zeit) And Zeit 0 Then
'Zeit und Datum eintragen
TB.Cells(Zeile, SpD) = Datum
TB.Cells(Zeile, SpD + 1) = Format(Zeit, "hh:mm")
'reset
Application.EnableEvents = False
RNG2 = ClearContents
Application.EnableEvents = True
MsgBox "Erledigt"
End If
End If
End If
'*** Fehlerbehandlung
Err.Clear
Fehler:
Application.EnableEvents = True
If Err.Number 0 Then MsgBox "Fehler in Sub """ & APPNAME & """" & vbCrLf _
& "Fehlernummer: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub
LG UweD