Zellen ausfüllen/bearbeiten mit VBA

[sveni_lee]

da waren doch noch einige Fehler drin...

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

[sveni_lee]

...
Die Dropdowns habe ich auch aufgeräumt und abhängig gemacht zwecks Fehlervermeidung in der Übergabe in die korrekte Zelle der Tabelle1.
....
 
Gruß Uwe

Hallo Uwe,

ich habe jetzt versucht die Matadaten zu erweitern aber ich komme damit nicht weiter...
wie hast Du die Metabellen formartiert?
Wenn ich eine neue Kategorie anlege kann ich ie Unterkategorie trozdem nicht auswählen...