21.09.2023, 14:05
da waren doch noch einige Fehler drin...
so sieht es besser aus...
so sieht es besser aus...
Code:
Option Explicit
' Überprüfung auf Vollständigkeit der Tabelle und Übergabe der Rate in die korrekte Zielzelle
Private Sub Worksheet_Change(ByVal Target As Range)
Dim iZeile&: iZeile = Target.Cells.Row
Dim arrKat(): arrKat = Array("Kategorie", "Unterkategorie", "Betrag", "bezahlt", "v. Konto", "Kapital")
Dim i&, j&, k&, rngKat As Range, lz&
Application.EnableEvents = False
If Not Intersect(Target, ListObjects(1).DataBodyRange) Is Nothing Then
For i = 1 To 6
If Cells(iZeile, i) = "" And i <> 2 Then
'MsgBox "In Spalte " & arrKat(i - 1) & "fehlt der Eintrag", vbExclamation, "Fehlende Auswahl/Eintrag"'
Cells(iZeile, i).Select
Application.EnableEvents = True
Exit Sub
ElseIf Cells(iZeile, i) = "" And i = 2 Then
Set rngKat = Tabelle1.Columns(1).Find(Cells(iZeile, 1))
For k = 1 To Tabelle3.Cells(1, Columns.Count).End(xlToLeft).Column
If Tabelle3.Cells(1, k) = rngKat.Value2 And Tabelle3.Cells(2, k) <> "" Then
Cells(iZeile, i).Select
Application.EnableEvents = True
Exit Sub
Exit For
ElseIf Tabelle3.Cells(1, k) = rngKat.Value2 And Tabelle3.Cells(2, k) = "" Then
Exit For
End If
Next k
End If
Next i
Set rngKat = Tabelle1.Columns(1).Find(Cells(iZeile, 1))
If Not rngKat Is Nothing Then
For i = rngKat.Row + 1 To Tabelle1.Cells(Rows.Count, 1).End(xlUp).Row
If Tabelle1.Cells(i, 1) <> rngKat.Value2 And Tabelle1.Cells(i, 1) <> "" Then
lz = i - 1
Exit For
End If
Next i
End If
For i = rngKat.Row To lz
If Tabelle1.Cells(i, 2) = Cells(iZeile, 2) Then
For j = 5 To Tabelle1.Cells(1, Columns.Count).End(xlToLeft).Column
If Format(Cells(iZeile, 4), "mmm yy") = Format(Tabelle1.Cells(1, j), "mmm yy") Then
If Tabelle1.Cells(i, j).Interior.Color = 11854022 Then
Tabelle1.Cells(i, j) = CDbl(Tabelle1.Cells(i, j)) + CDbl(Cells(iZeile, 3))
Else
Tabelle1.Cells(i, j).Interior.Color = 11854022
Tabelle1.Cells(i, j) = Format(CDbl(Cells(iZeile, 3)), "#,##0.00 €")
Tabelle1.Cells(i, j).NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
End If
End If
Next j
End If
Next i
End If
Application.EnableEvents = True
End Sub