Fehler im sortieren, Excel schließt beim Speichern unerwarte
13.06.2024 08:33:34
Jori
ich habe ein Problem mit meinem VBA-Script.
Ist-Zustand:
Ich habe eine Personalliste. in diese kann neues Personal hinzugefügt werden, nach dem Hinzufügen soll die Liste anschließend direkt sortiert werden.
Es funktioniert soweit auch alles, bis ich die Arbeitsmappe speichern will, dann schließt Excel einfach unerwartet. Sobald ich Excel wieder öffne, zeigt er mir Wiederherstellungsoptionen an und alle eingegebenen Daten sind nicht gespeichert.
Wenn ich die Sortieroption auskommentiere, dann speichert es auch die Daten, sortiert aber logischerweise nicht.
Private Sub CommandButton5_Click() 'Neues Personal
Dim Zeilennummer As Byte
Application.ScreenUpdating = False 'verhindert Bildschirmaktualisierungen
Worksheets("Berechnungstabelle").Visible = True
Worksheets("Datenbank").Visible = True
Zeilennummer = Worksheets("Berechnungstabelle").Range("G11").Value
If TextBox2.Value = "" Then
MsgBox "Bitte alle Daten vollständig eingeben!"
Else
Worksheets("Datenbank").Range("A" & Zeilennummer).Value = TextBox2.Value 'Name
Worksheets("Datenbank").Range("B" & Zeilennummer).Value = TextBox3.Value 'Vorname
Worksheets("Datenbank").Range("C" & Zeilennummer).Value = ComboBox2.Value 'Zusatz
Worksheets("Datenbank").Range("D" & Zeilennummer).Value = ComboBox3.Value 'Zusatz2
Worksheets("Datenbank").Range("E" & Zeilennummer).Value = TextBox4.Value 'Personalnummer
Worksheets("Datenbank").Range("F" & Zeilennummer).Value = ComboBox1.Value 'Geschlecht
Dim lngCLC As Long
Dim lngListExist As Long
Dim lngOC As Long
Dim vListArr As Variant
vListArr = Worksheets("Berechnungstabelle").Range("C3:C22").Value
lngListExist = Application.GetCustomListNum(vListArr)
If lngListExist > 0 Then
lngOC = lngListExist + 1
Else
Application.AddCustomList listArray:=vListArr
lngCLC = Application.CustomListCount
lngOC = lngCLC + 1
End If
Worksheets("Datenbank").Range("A2:IM46").Sort Key1:=Worksheets("Datenbank").Range("C2"), Key2:=Worksheets("Datenbank").Range("A2"), Order1:=xlDescending, _
Header:=xlYes, OrderCustom:=lngOC, _
MatchCase:=False, Orientation:=xlTopToBottom
If lngListExist = 0 Then Application.DeleteCustomList ListNum:=lngCLC
End If
Worksheets("Berechnungstabelle").Visible = False
Worksheets("Datenbank").Visible = False
Application.ScreenUpdating = True
End Sub
Vielen Dank :)
Anzeige