Hallo Ralf
ich meine der Code stammt ursprünglich von mir.
Das eigentliche Problem schein hier zu sein.
RNG9.FormulaR1C1 = "=IF(Kalkulation!R[-12]C>0,(Kalkulation!R[-12]C),Datenbank!R[-17]C[17])"
Ich hab ihn nochmal "aufgeräumt", aber NICHT getestet
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, SpN As Integer, SpL As Integer, SpV As Integer, SpA As Integer, SpX As Integer, SpY As Integer, SpZ As Integer
Dim RNG1 As Range, RNG2 As Range, RNG3 As Range, RNG4 As Range, RNG5 As Range, RNG6 As Range, RNG7 As Range, RNG8 As Range, RNG9 As Range, RNG10 As Range, RNG11 As Range, Zelle As Range
'On Error GoTo Fehler
Const APPNAME = "Worksheet_Change"
Set TB = Sheets("Datenbank")
SpK = 2 'Spalte der Kundennummer =B
SpD = 15 'Spalte mit Datum =O + P
SpR = 13 'Spalte mit Kommentar = N
SpG = 9 'Spalte mit Zusatzinformation = J
SpS = 17 'Spalte für Kundenstatus = Q
SpN = 19 'Spalte für Angebotsnummer = S
SpL = 20 'Spalte für Listenpreis = T
SpV = 21 'Spalte für Verkauspreis = U
SpA = 18 'Spalte für Angebotsdatum = R
SpX = 22 'Spalte für Jahresverbrauch = V
SpY = 23 ' Spalte für Anlagengröße
SpZ = 24 'Spalte für Speicher
Set RNG1 = Range("C13") 'Kommentar
Set RNG2 = Range("C14,C15") 'Datum Uhrzeit
Set RNG3 = Range("C11") 'Info oder Mobil oder Mail
Set RNG4 = Range("C12") 'Kundenstaus
Set RNG5 = Range("D12") 'Angebotsnummer
Set RNG6 = Range("K17") 'Listenpreis
Set RNG7 = Range("K20") 'Verkaufspreis
Set RNG8 = Range("N18") 'Verkaufspreis
Set RNG9 = Range("E18") 'Jahresverbrauch
Set RNG10 = Range("E19") 'Anlagengröße
Set RNG11 = Range("E20") 'Speicher
'MsgBox Target.Address
Dim X As Boolean
'NUR, wenn in C4 oder C14 eine Änderung erfolgt, werden in der Vorlage die Pflichtfelder wieder geleert
If Target.Address = "$C$4" Or _
Target.Address = "$C$14" Then 'C4 ist die Zelle, in der Kundennr eingegeben wird; $-Zeichen nicht entfernen;C14 = Uhrzeiteingabe
Sheets("Terminvorlage").Range("leeren").Value = "" 'das, was du "per Hand" mit leeren - delete - ok - delete gemacht hast, passiert hier mit dem einen Befehl
Sheets("Kalkulation").Range("leerenKalk").Value = "" 'das, was du "per Hand" mit leeren - delete - ok - delete gemacht hast, passiert hier mit dem einen Befehl
If Sheets("Datenblatt").ProtectContents Then
Sheets("Datenblatt").Unprotect "tresor1958"
X = True
End If
Sheets("Datenblatt").Range("leerenDat").Value = ""
If X Then Sheets("Datenblatt").Protect "tresor1958"
End If
'nur bei Änderungen in diesen Zellen auslösen
If Not Intersect(Union(RNG1, RNG2, RNG3, RNG4, RNG5, RNG6, RNG7, RNG8, RNG9, RNG10, RNG11), 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("C14")
Zeit = Range("C15")
'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")
'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 = "": RNG4 = "": RNG5 = "": RNG6 = "=N17": RNG7 = "=N20": RNG8 = "=N15"
RNG9.FormulaR1C1 = "=IF(Kalkulation!R[-12]C>0,(Kalkulation!R[-12]C),Datenbank!R[-17]C[17])"
RNG10 = "=F19": RNG11 = "=F20"
Application.EnableEvents = True
MsgBox "Erledigt"
End If
End If
If Not Intersect(RNG3, Target) Is Nothing Then
'Info Mobil und Mail eintragen
TB.Cells(Zeile, SpR).Offset(0, Target.Column - 6) = Target
End If
If Not Intersect(RNG4, Target) Is Nothing Then
'Kundenstatus eintragen
TB.Cells(Zeile, SpS).Value = Target.Value
End If
If Not Intersect(RNG5, Target) Is Nothing Then
'Angebotsnummer eintragen
TB.Cells(Zeile, SpN).Value = Target.Value
End If
'Listenpreis
TB.Cells(Zeile, SpL).Value = RNG6.Value
'Verkaufspreis
TB.Cells(Zeile, SpV).Value = RNG7.Value
'Angebotsdatum
TB.Cells(Zeile, SpA).Value = RNG8.Value
'Jahresverbrauch
TB.Cells(Zeile, SpX).Value = RNG9.Value
'Anlagengröße
TB.Cells(Zeile, SpY).Value = RNG10.Value
'Speicher
TB.Cells(Zeile, SpZ).Value = RNG11.Value
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
