Benutzerdefinierte Sortierung
14.10.2020 09:47:45
Rösch
ich bin am Verzweifeln.
Mein Projekt Funktioniert soweit einwandfrei nur, wenn ich meine Benutzerdefinierte Sortierung im VBA durchlaufenlasse, gibt es auch kein Problem. Erst wenn die Datei gespeichert werden soll, stürzt Excel ab.
Kann mir jemand Helfen.
Danke euch schon mal für eure Hilfe.
Sub Nach_TE_DG_Sortieren()
Dim TE1 As String
Dim TE2 As String
Dim TE3 As String
Dim TE4 As String
Dim TE5 As String
Dim TE6 As String
Dim TE7 As String
Dim TE8 As String
Dim TE9 As String
Dim TE10 As String
Dim TE11 As String
Dim TE12 As String
Dim TE13 As String
Dim TE14 As String
Dim TE15 As String
Dim TE16 As String
Dim TE17 As String
Dim TE18 As String
Dim TE19 As String
Dim TE20 As String
TE1 = ActiveWorkbook.Sheets("Daten").Range("E11").Value
TE2 = ActiveWorkbook.Sheets("Daten").Range("E12").Value
TE3 = ActiveWorkbook.Sheets("Daten").Range("E13").Value
TE4 = ActiveWorkbook.Sheets("Daten").Range("E14").Value
TE5 = ActiveWorkbook.Sheets("Daten").Range("E15").Value
TE6 = ActiveWorkbook.Sheets("Daten").Range("E16").Value
TE7 = ActiveWorkbook.Sheets("Daten").Range("E17").Value
TE8 = ActiveWorkbook.Sheets("Daten").Range("E18").Value
TE9 = ActiveWorkbook.Sheets("Daten").Range("E19").Value
TE10 = ActiveWorkbook.Sheets("Daten").Range("E20").Value
TE11 = ActiveWorkbook.Sheets("Daten").Range("E21").Value
TE12 = ActiveWorkbook.Sheets("Daten").Range("E22").Value
TE13 = ActiveWorkbook.Sheets("Daten").Range("E23").Value
TE14 = ActiveWorkbook.Sheets("Daten").Range("E24").Value
TE15 = ActiveWorkbook.Sheets("Daten").Range("E25").Value
TE16 = ActiveWorkbook.Sheets("Daten").Range("E26").Value
TE17 = ActiveWorkbook.Sheets("Daten").Range("E27").Value
TE18 = ActiveWorkbook.Sheets("Daten").Range("E28").Value
TE19 = ActiveWorkbook.Sheets("Daten").Range("E29").Value
TE20 = ActiveWorkbook.Sheets("Daten").Range("E30").Value
' Nach TE und DG sortieren
Application.ScreenUpdating = False
Dim WKSheet As String
ActiveSheet.Unprotect Password:="YH50trom?"
WKSheet = ActiveSheet.Name
Dim lngCLC As Long
Dim lngListExist As Long
Dim lngOC As Long
Dim vListArr As Variant
If WKSheet = "1. Halbjahr" Then 'Die IF Anweisung ist dafür da, weil das 1.Halbjahr und das _
_
_
_
2.Halbjahr einen anderen Sortierbereich haben
ActiveWorkbook.Worksheets(WKSheet).AutoFilter.Sort.SortFields.Clear
'erste Sortierung nach Dienstgrad
vListArr = Array("M", "H", "OL", "Lt", "OSF", "SF", "OFR", "HF", "OF", "FR", "F", "SU", " _
Fhj", "U", "OSG", "SG", "HG", "OG", "G", "Jg")
lngListExist = Application.GetCustomListNum(vListArr)
If lngListExist > 0 Then
lngOC = lngListExist + 1
Else
Application.AddCustomList listArray:=vListArr
lngCLC = Application.CustomListCount
lngOC = lngCLC + 1
End If
Range("A139:GE585").Sort Key1:=Range("B139"), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=lngOC, _
MatchCase:=False, Orientation:=xlTopToBottom
If lngListExist = 0 Then Application.DeleteCustomList ListNum:=lngCLC
'zweite Sortierung nach Teileinheit
vListArr = Array(TE1, TE2, TE3, TE4, TE5, TE6, TE7, TE8, TE9, TE10, TE11, TE12, TE13, TE14, _
_
_
_
TE15, TE16, TE17, TE18, TE19, TE20)
lngListExist = Application.GetCustomListNum(vListArr)
If lngListExist > 0 Then
lngOC = lngListExist + 1
Else
Application.AddCustomList listArray:=vListArr
lngCLC = Application.CustomListCount
lngOC = lngCLC + 1
End If
Range("A139:GE585").Sort Key1:=Range("A139"), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=lngOC, _
MatchCase:=False, Orientation:=xlTopToBottom
If lngListExist = 0 Then Application.DeleteCustomList ListNum:=lngCLC
ActiveWorkbook.Worksheets(WKSheet).Range("F140").Select
ActiveSheet.Protect Password:="YH50trom?", DrawingObjects:=False, Contents:=True, _
Scenarios:=True _
, AllowFormattingCells:=True, AllowSorting:=True, AllowFiltering:=True
End If
If WKSheet = "2. Halbjahr" Then 'Die IF Anweisung ist dafür da, weil das 1.Halbjahr und das _
_
_
_
2.Halbjahr einen anderen Sortierbereich haben
ActiveWorkbook.Worksheets(WKSheet).AutoFilter.Sort.SortFields.Clear
'erste Sortierung nach Dienstgrad
vListArr = Array("M", "H", "OL", "Lt", "OSF", "SF", "OFR", "HF", "OF", "FR", "F", "SU", " _
Fhj", "U", "OSG", "SG", "HG", "OG", "G", "Jg")
lngListExist = Application.GetCustomListNum(vListArr)
If lngListExist > 0 Then
lngOC = lngListExist + 1
Else
Application.AddCustomList listArray:=vListArr
lngCLC = Application.CustomListCount
lngOC = lngCLC + 1
End If
Range("A139:GG585").Sort Key1:=Range("B139"), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=lngOC, _
MatchCase:=False, Orientation:=xlTopToBottom
If lngListExist = 0 Then Application.DeleteCustomList ListNum:=lngCLC
'zweite Sortierung nach Teileinheit
vListArr = Array(TE1, TE2, TE3, TE4, TE5, TE6, TE7, TE8, TE9, TE10, TE11, TE12, TE13, TE14, _
_
_
_
TE15, TE16, TE17, TE18, TE19, TE20)
lngListExist = Application.GetCustomListNum(vListArr)
If lngListExist > 0 Then
lngOC = lngListExist + 1
Else
Application.AddCustomList listArray:=vListArr
lngCLC = Application.CustomListCount
lngOC = lngCLC + 1
End If
Range("A139:GG585").Sort Key1:=Range("A139"), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=lngOC, _
MatchCase:=False, Orientation:=xlTopToBottom
If lngListExist = 0 Then Application.DeleteCustomList ListNum:=lngCLC
ActiveWorkbook.Worksheets(WKSheet).Range("F140").Select
ActiveSheet.Protect Password:="YH50trom?", DrawingObjects:=False, Contents:=True, _
Scenarios:=True _
, AllowFormattingCells:=True, AllowSorting:=True, AllowFiltering:=True
End If
ThisWorkbook.Worksheets(WKSheet).Activate
Application.ScreenUpdating = True
End Sub