Zellen bei Sub Worksheet_Change Ereignis ändern

[Josch]

Hallo wertes Forum,

ich habe ein ganz ähnliches Problem, aber mit meinen rudimentären VBA-Kenntnissen war ich nicht in der Lage, die genannte Lösung auch auf meinen Code anzuwenden. Vielleicht könnt ihr mir helfen?
Im Wesentlichen wird in meiner Tabelle ein Betrag aus Spalte G im "Kalenderbereich" meiner Tabelle (ab Spalte N) eingetragen und zwar immer bei dem Tag, welcher in Spalte K steht (prognostizierte Zahlung). Ausnahme: In Spalte L (tatsächliche Zahlung) steht ein Datum, dann wird das bisherige überschrieben.
Bis auf 1-2 Zicken funktioniert der Code auch ganz gut, den ich mit freundlicher Unterstützung dieses Forums zusammengebastelt habe.

Mein Problem, ähnlich wie bei mausgambler, ist, dass bei Änderung mehrerer Daten gleichzeitig in Spalte K oder L (z.B. markieren und löschen mehrerer Daten), nur eine Verteilung im "Kalenderbereich" auch wirklich gelöscht wird. Es wäre super, wenn mir hier jemand unter die Arme greifen könnte.

Mein Makro ist wie folgt:

Code:

Private Sub Worksheet_Change(ByVal Target As Range)

'Events aktivieren
Application.EnableEvents = True

'Wenn kein Eintrag in Spalte 7 [G] oder 11 [K] oder 12 [L], dann Makro verlassen
If Target.Column <> 7 And Target.Column <> 8 And Target.Column <> 10 And Target.Column <> 11 And Target.Column <> 12 Then Exit Sub
If Target.Row < 29 Then Exit Sub

'Gehe bei Fehler zur Fehlerbehandlung
On Error GoTo errorhandler

'Events deaktivieren
Application.EnableEvents = False

   'Wenn in H was steht und in J und K nichts steht, dann Datum H + Standard-Zahlungsziel (F19 = Zelle(19, 6)) in K eintragen
   If Cells(Target.Row, 8).Value <> "" And Cells(Target.Row, 10).Value = "" And Cells(Target.Row, 11).Value = "" Then
   Cells(Target.Row, 11).Value = Cells(Target.Row, 8).Value + Cells(19, 6).Value
   End If

   'Wenn in J was steht Inhalt von H l?schen
   If Cells(Target.Row, 10).Value <> "" Then
   Cells(Target.Row, 8).ClearContents
   End If

   'Wenn in J was steht und in K nichts steht, dann Datum J + Standard-Zahlungsziel (F19 = Zelle(19, 6)) in K eintragen
   If Cells(Target.Row, 10).Value <> "" And Cells(Target.Row, 11).Value = "" Then
   Cells(Target.Row, 11).Value = Cells(Target.Row, 10).Value + Cells(19, 6).Value
   End If

'Startzahl fuer 1.1.2018
Const lStart = 43101

'Zeile ab Spalte N leeren
Cells(Target.Row, 14).Resize(1, 366) = ""

'Wenn in K was steht, dann Betrag bei Datum von K eintragen
If Cells(Target.Row, 11).Value Then Cells(Target.Row, CDbl(Cells(Target.Row, 11).Value) - lStart + 14) = Cells(Target.Row, 7).Value

'Wenn in L was steht, dann
If Cells(Target.Row, 12).Value Then

   'Wenn in K was steht, dann
   If Cells(Target.Row, 11).Value Then
   Cells(Target.Row, CDbl(Cells(Target.Row, 11).Value) - lStart + 14) = ""

   'Ende Wenn in H was steht, dann
   End If

   'Betrag bei Datum von L eintragen
   Cells(Target.Row, CDbl(Cells(Target.Row, 12).Value) - lStart + 14) = Cells(Target.Row, 7).Value

'Ende Wenn in L was steht, dann
End If

errorhandler:
'Events deaktivieren
Application.EnableEvents = True

'Ausgabe einer Fehlermeldung
If Err Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description

End Sub

Vielen Dank im Voraus!

Gruß
Josch

Mod: aus diesem Thread abgehängt https://www.clever-excel-forum.de/thread-17490.html

[Steffl]

Hallo Josch,

ich habe es nicht verstanden, aber versuche es mal so

Code:

Private Sub Worksheet_Change(ByVal Target As Range)

Dim rngZelle As Range

'Events aktivieren
'Application.EnableEvents = True

'Wenn kein Eintrag in Spalte 7 [G] oder 11 [K] oder 12 [L], dann Makro verlassen
If Target.Column <> 7 And Target.Column <> 8 And Target.Column <> 10 And Target.Column <> 11 And Target.Column <> 12 Then Exit Sub
If Target.Row < 29 Then Exit Sub

'Gehe bei Fehler zur Fehlerbehandlung
On Error GoTo errorhandler

'Events deaktivieren
Application.EnableEvents = False

   'Wenn in H was steht und in J und K nichts steht, dann Datum H + Standard-Zahlungsziel (F19 = Zelle(19, 6)) in K eintragen
   If Cells(Target.Row, 8).Value <> "" And Cells(Target.Row, 10).Value = "" And Cells(Target.Row, 11).Value = "" Then
   Cells(Target.Row, 11).Value = Cells(Target.Row, 8).Value + Cells(19, 6).Value
   End If

   'Wenn in J was steht Inhalt von H l?schen
   If Cells(Target.Row, 10).Value <> "" Then
   Cells(Target.Row, 8).ClearContents
   End If

   'Wenn in J was steht und in K nichts steht, dann Datum J + Standard-Zahlungsziel (F19 = Zelle(19, 6)) in K eintragen
   If Cells(Target.Row, 10).Value <> "" And Cells(Target.Row, 11).Value = "" Then
   Cells(Target.Row, 11).Value = Cells(Target.Row, 10).Value + Cells(19, 6).Value
   End If

'Startzahl fuer 1.1.2018
Const lStart = 43101

'Zeile ab Spalte N leeren
Cells(Target.Row, 14).Resize(1, 366) = ""


For Each rngZelle In Target.Cells
'Wenn in K was steht, dann Betrag bei Datum von K eintragen
If Cells(rngZelle.Row, 11).Value Then Cells(rngZelle.Row, CDbl(Cells(rngZelle.Row, 11).Value) - lStart + 14) = Cells(rngZelle.Row, 7).Value

'Wenn in L was steht, dann
If Not IsEmpty(Cells(rngZelle.Row, 12).Value) Then

   'Wenn in K was steht, dann
   If Cells(rngZelle.Row, 11).Value Then
   Cells(rngZelle.Row, CDbl(Cells(rngZelle.Row, 11).Value) - lStart + 14) = ""

   'Ende Wenn in H was steht, dann
   End If

   'Betrag bei Datum von L eintragen
   Cells(rngZelle.Row, CDbl(Cells(rngZelle.Row, 12).Value) - lStart + 14) = Cells(rngZelle.Row, 7).Value

'Ende Wenn in L was steht, dann
End If
Next rngZelle
errorhandler:
'Events deaktivieren
Application.EnableEvents = True

'Ausgabe einer Fehlermeldung
If Err Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description

End Sub

[Josch]

Hallo Stefan,

danke für die schnelle Antwort. Leider war das noch nicht des Rätsels Lösung.

Ich versuche es nochmal zu erläutern mit einem kleinen Screenshot:

Dateien bitte im Forum hochladen: https://www.clever-excel-forum.de/thread-326.html

Bei Ausfüllen der erw. Zahlung (Spalte K) wird der Betrag (Spalte G) im Kalender (Spalte N....) verteilt --> hier in Zeile 49.
Bei Ausfüllen der tatsächlichen Zahlung (Spalte L) wird der bereits verteilte Betrag gelöscht und neu verteilt gem. Datum in Spalte L --> hier in Zeile 50.

Das Problem ist, würde ich hier alle 3 Daten 03.01.2018 markieren und löschen würden nur die 2.000 € am 03.01.18 gelöscht werden, die 3.000€ und 4.000€ leider nicht.

(Außerdem im Code vorhanden aber hier unwichtig: trägt man in den Spalten H oder J ein Rechnungs-Datum ein, wird in Spalte K eine erwartete Zahlung (gem. Inhalt der Zelle F19) prognostiziert.)


Hoffentlich ist mein Problem auf diese Weise besser verständlich geworden. Vielleicht kann ja jemand helfen?

Besten Gruß
Josch

[WillWissen]

Hallo Josch,

Bilder sind in der Regel kein adäquates Mittel zum Helfen. Lade anstelle von ScrShots bitte eine Beispieldatei oder relevante Tabellenausschnitte mit einem Tool hoch.

[Josch]

Hallo,

danke für den Hinweis (hat ja eh nicht geklappt, wie es sollte).
Ich habe mal eine Beispieldatei angehängt. Relevant ist die Verteilung ab Spalte N bei Änderungen in Spalten K und L. Z.Z. funktioniert dies nicht, wenn mehrere Inhalte in K und L gleichzeitig geändert werden (z.B. durch markieren und löschen mehrerer Zellen).

Über jede Art von Hilfe würde ich mich freuen.

Danke.
Josch

[Steffl]

Hallo,

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
   Dim rngZelle As Range
   'Total unnötig
   ''Events aktivieren
   'Application.EnableEvents = True
   'Wenn kein Eintrag in Spalte 7 [G] oder 11 [K] oder 12 [L], dann Makro verlassen
   If Target.Column <> 7 And Target.Column <> 8 And Target.Column <> 10 And Target.Column <> 11 And Target.Column <> 12 Then Exit Sub
   If Target.Row < 29 Then Exit Sub
   'Gehe bei Fehler zur Fehlerbehandlung
   On Error GoTo errorhandler
   'Events deaktivieren
   Application.EnableEvents = False
   For Each rngZelle In Target.Cells
      'Wenn in H was steht und in J und K nichts steht, dann Datum H + Standard-Zahlungsziel (F19 = Zelle(19, 6)) in K eintragen
      If Cells(rngZelle.Row, 8).Value <> "" And Cells(rngZelle.Row, 10).Value = "" And Cells(rngZelle.Row, 11).Value = "" Then
         Cells(rngZelle.Row, 11).Value = Cells(rngZelle.Row, 8).Value + Cells(19, 6).Value
      End If
      'Wenn in J was steht Inhalt von H löschen
      If Cells(rngZelle.Row, 10).Value <> "" Then
         Cells(rngZelle.Row, 8).ClearContents
      End If
      'Wenn in J was steht und in K nichts steht, dann Datum J + Standard-Zahlungsziel (F19 = Zelle(19, 6)) in K eintragen
      If Cells(rngZelle.Row, 10).Value <> "" And Cells(rngZelle.Row, 11).Value = "" Then
         Cells(rngZelle.Row, 11).Value = Cells(rngZelle.Row, 10).Value + Cells(19, 6).Value
      End If
      'Startzahl fuer 1.1.2018
      Const lStart = 43101
      'Zeile ab Spalte N leeren
      Cells(rngZelle.Row, 14).Resize(1, 366) = ""
      'Wenn in K was steht, dann Betrag bei Datum von K eintragen
      If Cells(rngZelle.Row, 11).Value Then Cells(rngZelle.Row, CDbl(Cells(rngZelle.Row, 11).Value) - lStart + 14) = Cells(rngZelle.Row, 7).Value
      'Wenn in L was steht, dann
      If Cells(rngZelle.Row, 12).Value Then
         'Wenn in K was steht, dann
         If Cells(rngZelle.Row, 11).Value Then
            Cells(rngZelle.Row, CDbl(Cells(rngZelle.Row, 11).Value) - lStart + 14) = ""
            'Ende Wenn in H was steht, dann
         End If
         'Betrag bei Datum von L eintragen
         Cells(rngZelle.Row, CDbl(Cells(rngZelle.Row, 12).Value) - lStart + 14) = Cells(rngZelle.Row, 7).Value
         'Ende Wenn in L was steht, dann
      End If
   Next rngZelle
errorhandler:
   'Events deaktivieren
   Application.EnableEvents = True
   'Ausgabe einer Fehlermeldung
   If Err Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description
End Sub

[Josch]

Großartig, es funktioniert wie gewünscht. Danke!