AW: Probleme mit tbl.Listrows.add
23.04.2024 15:08:15
ralf_b
Evtl kommt der Fehler weil du im Namensmanager die Tabelle zweimal verwendet hast. Auch ich mußte die intelligente Tabelle neu erstellen.
Ich war auch mal so frei und hab deine Makros etwas umgebastelt.
H14 erhält eine Dropdownliste wenn eine neue Zeile in die Datenbank geschrieben wird.
Ich habe das Listrow Objekt benutzt.
Anlegen_DBEingabe = nur Eingabeformular leermachen und in H14 wird Neu "geschrieben"
Formularfuellen(Optional id& = 0) = wird aufgerufen wenn H14 sich ändert über Worksheet_Change.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(0, 0) = "H14" Then
Formularfuellen IIf(Target.Value = "", 0, Target.Value)
End If
End Sub
Change_EingabeDB = setzt die Listrow auf eine neue Zeile oder auf die Bekannte.
ListeAktualisieren =setzt dropdownliste in H14
Sub Change_EingabeDB()
'Tabelle einlesen
Dim tab_1 As ListObject
Dim lstrow As ListRow
Set tab_1 = tb_Datenbank.ListObjects("tblAltbestand")
Dim Zeile
'Anlegen oder Bearbeiten?
If tb_Bearbeitung.Range("H14").Value = "Neu" Then
Set lstrow = tab_1.ListRows.Add
lstrow.Range(1) = WorksheetFunction.Max(tab_1.ListColumns("ID-Nr.").DataBodyRange) + 1
ListeAktualisieren
Else
Zeile = Application.WorksheetFunction.Match(tb_Bearbeitung.Range("H14").Value, tab_1.ListColumns("ID-Nr.").DataBodyRange, 0)
If IsNumeric(Zeile) Then
Set lstrow = tab_1.ListRows(Zeile)
Else
Set lstrow = Nothing
End If
End If
If Not lstrow Is Nothing Then
'Datenbank befüllen
With tb_Bearbeitung
Application.EnableEvents = False
'lstrow.Range(1).Value = .Range("H14").Value 'wird nur bei Neu gesetzt.
lstrow.Range(4).Value = .Range("H20").Value
lstrow.Range(6).Value = .Range("H22").Value
lstrow.Range(5).Value = .Range("H24").Value
lstrow.Range(8).Value = .Range("H26").Value
lstrow.Range(2).Value = .Range("L20").Value
lstrow.Range(3).Value = .Range("L22").Value
lstrow.Range(7).Value = .Range("L24").Value
lstrow.Range(9).Value = Date
.Range("H14,H20,H22,H24,H26,L20,L22,L24").ClearContents
Application.EnableEvents = True
End With
End If
End Sub
Sub Anlegen_DBEingabe()
'Tabelle einlesen
Dim tbl As ListObject
Set tbl = tb_Datenbank.ListObjects(1)
With Worksheets("Eingabeformular")
Application.EnableEvents = False
.Range("H14,H20,H22,H24,H26,L20,L22,L24").ClearContents
'ID-Nr. einfügen
.Range("H14").Value = "Neu" ' WorksheetFunction.Max(tbl.ListColumns("ID-Nr.").DataBodyRange) + 1
Application.EnableEvents = True
End With
End Sub
Sub Formularfuellen(Optional id& = 0)
'Tabelle einlesen
Dim tbl As ListObject, lstrow As ListRow, Zeile
Set tbl = tb_Datenbank.ListObjects(1)
With Worksheets("Eingabeformular")
Application.EnableEvents = False
.Range("H20,H22,H24,H26,L20,L22,L24").ClearContents
If id > 0 Then
Zeile = Application.WorksheetFunction.Match(id, tbl.ListColumns("ID-Nr.").DataBodyRange, 0)
If IsNumeric(Zeile) Then
Set lstrow = tbl.ListRows(Zeile)
'Eingabeformular befüllen
'.Range("H14").Value = lstrow.Range(1).Value 'dropdown: einlesen unnötig
.Range("H20").Value = lstrow.Range(4).Value
.Range("H22").Value = lstrow.Range(6).Value
.Range("H24").Value = lstrow.Range(5).Value
.Range("H26").Value = lstrow.Range(8).Value
.Range("L20").Value = lstrow.Range(2).Value
.Range("L22").Value = lstrow.Range(3).Value
.Range("L24").Value = lstrow.Range(7).Value
Application.EnableEvents = True
End If
End If
End With
End Sub
Sub ListeAktualisieren()
'dropdown für H14
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=Altbestand!" & tb_Datenbank.ListObjects(1).ListColumns(1).DataBodyRange.Address
.IgnoreBlank = True
.InCellDropdown = True
.ShowInput = True
.ShowError = True
End With
End Sub