AW: Info ablegen in Datei klappt nicht
15.12.2021 09:06:56
UweD
Hallo
hatte mich gestern schon gewundert, warum der Beitrag weg war.
Versuch es so:
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, SpG As Integer
Dim RNG1 As Range, RNG2 As Range, RNG3 As Range, Zelle As Range
'On Error GoTo Fehler
Const APPNAME = "Worksheet_Change"
Set TB = Sheets("Datenbank")
SpK = 2 'Spalte der Kundennummer =B
SpD = 17 'Spalte mit Datum =l
SpR = 13 'Spalte mit Kommentar = l
SpG = 9 'Spalte mit Gespächsnotizen = I
Set RNG1 = Range("C12") 'Kommentar
Set RNG2 = Range("C13,C14") 'Datum Uhrzeit
Set RNG3 = Range("C11") 'Info oder Mobil nachtragen
'nur bei Änderungen in diesen Zellen auslösen
If Not Intersect(Union(RNG1, RNG2, RNG3), Target) Is Nothing Then
Kunu = Range("C4")
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
End If
If Not Intersect(RNG2, Target) Is Nothing Then
Datum = Range("C13")
Zeit = Range("C14")
'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")
'KD Nr. Matchcode eintragen
Range("D4").FormulaR1C1 = "=R1C1" 'als Formel
Range("D4").FormulaR1C1 = "=R1C2"
'Gesprächsnotizen eintragen/löschen
For Each Zelle In RNG3
If Zelle.Text "" Then
If Target.Offset(0, 1).Text "0" Then
If MsgBox("Soll die vorhandene Notiz in der Zeile " _
& Zelle.Row & " überschrieben werden?", _
vbQuestion + vbOKCancel + vbDefaultButton2, _
"Eintrag überschreiben") = vbOK Then
TB.Cells(Zeile, SpG).Offset(0, Zelle.Row - 10) = _
Zelle.Text
End If
Else
TB.Cells(Zeile, SpG).Offset(0, Zelle.Row - 10).Value = _
Zelle.Text
End If
End If
Next
'reset
Application.EnableEvents = False
RNG1 = "": RNG2 = "": RNG3 = ""
Application.EnableEvents = True
MsgBox "Erledigt"
End If
End If
If Not Intersect(RNG3, Target) Is Nothing Then
'Info eintragen
TB.Cells(Zeile, SpR).Offset(0, Target.Column - 6) = Target
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