Benutzerdefinierte Sortierung

Bewerten Sie hier bitte das Excel-Portal

Der kurze Weg zum Ziel: Auftragsprogrammierung

Benutzerdefinierte Sortierung

Benutzerdefinierte Sortierung von Rösch Thomas vom 14.10.2020 09:47:45

AW: Benutzerdefinierte Sortierung - von Nepumuk am 14.10.2020 10:07:44
- AW: Benutzerdefinierte Sortierung - von Rösch Thomas am 14.10.2020 10:41:17
  - AW: Benutzerdefinierte Sortierung - von Nepumuk am 14.10.2020 10:51:26
    - AW: Benutzerdefinierte Sortierung - von Rösch Thomas am 14.10.2020 11:00:14
      - AW: CustomList mehrfach anlegen? - von Fennek am 14.10.2020 11:06:23
AW: Benutzerdefinierte Sortierung - von Daniel am 14.10.2020 11:10:05

Betrifft: Benutzerdefinierte Sortierung von: Rösch Thomas
Geschrieben am: 14.10.2020 09:47:45

Guten Morgen NG,

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

Betrifft: AW: Benutzerdefinierte Sortierung
von: Nepumuk
Geschrieben am: 14.10.2020 10:07:44

Hallo Thomas,

so auf den ersten Blick kann ich nichts entdecken was den Fehler auslöst.

Kopiere mal die Daten der Tabelle in eine neue Tabelle. Aber nur Werte, keine Formate. Dann lösch die alte Tabelle und teste nochmal. Natürlich in einer Kopie der Mappe. Eventuell ist die Tabelle korrupt.

Gruß
Nepumuk

Betrifft: AW: Benutzerdefinierte Sortierung
von: Rösch Thomas
Geschrieben am: 14.10.2020 10:41:17

Hallo Nepumuk,
ich habe auch schon mal eine komplett neue Excel Mappe erstellt.
der Fehler bleibt trotzdem bestehen.
Gruß
Thomas

Betrifft: AW: Benutzerdefinierte Sortierung
von: Nepumuk
Geschrieben am: 14.10.2020 10:51:26

Hallo Thomas,

dann habe ich keine weitere Idee. Ich lass die Frage offen.

Gruß
Nepumuk

Betrifft: AW: Benutzerdefinierte Sortierung
von: Rösch Thomas
Geschrieben am: 14.10.2020 11:00:14

Danke Dir trotzdem.

Betrifft: AW: CustomList mehrfach anlegen?
von: Fennek
Geschrieben am: 14.10.2020 11:06:23

Hallo,

teste doch mal, ob die CustomList bereit existiert und lege sie nur im negativen Fall an.

ungeprüft.

mfg

Betrifft: AW: Benutzerdefinierte Sortierung
von: Daniel
Geschrieben am: 14.10.2020 11:10:05

Hi

Eine Alternative zur benutzerdefinierten Liste wäre folgende:

Lege eine zusätzliche Tabelle an, benennen sie "Stammdaten" (oder wie auch immer)

Liste dort die Ränge "M" bis "JG" in Spalte auf und schreibe daneben die Rangstufe als Zahl ("M":1;"H":2; usw)

In der Tabelle fügst du dann eine Hilfsspalte ein, in welcher du per SVerweis-Funktion zum jeweiligen Rang die Sortierreihenfolge zuspielst.
Verwende dann die Hilfsspalte als Sortierkriterium.

Da du mit VBA arbeitet, kannst du die Hilfsspalte ja im Makro hinzufügen und wieder löschen, wenn sie nicht in der Liste auftauchen sollen.

Das sollte auf jeden Fall funktionieren.

Gruß Daniel

Herbers Excel/VBA-Archiv

Der kurze Weg zum Ziel: Auftragsprogrammierung

Benutzerdefinierte Sortierung