HERBERS Excel-Forum - VBA-Basics

Thema: Sortieren

Inhaltsverzeichnis
  • 1 Schnelle VBA-Sortierroutine
  • 2 Dialog zur Verzeichnisauswahl
  • 3 Auslesen der Dateinamen in einem Verzeichnis
  • 4 Sortieren der Dateien eines Verzeichnisses nach Dateiname
  • 5 Sortieren der Dateien eines Verzeichnisses nach Dateidatum
  • 6 Sortieren der Arbeitsblätter der aktiven Arbeitsmappe
  • 7 Sortieren einer Tabelle nach einer benutzerdefinierten Sortierfolge
  • 8 Sortieren einer Datums-Tabelle ohne Einsatz der Excel-Sortierung
  • 9 Sortieren einer Tabelle nach sechs Sortierkriterien
  • 10 Sortieren mit Ae vor Ä und Sch vor S
  • 11 Sortieren nach der Häufigkeit des Vorkommens
  • 12 Sortieren einschließlich der ausgeblendeten Zeilen
  • 13 Sortieren mehrerer Tabellenblattbereiche
  • 14 Direkter Aufruf des Sortierdialogs
  • 15 Aufruf des Sortierdialogs unter Einsatz der Sortier-Schaltfläche
  • Schnelle VBA-Sortierroutine

    Autor: John Green

    
    Sub QuickSort(ByRef VA_array, Optional V_Low1, Optional V_high1)
        On Error Resume Next
        Dim V_Low2, V_high2, V_loop As Integer
        Dim V_val1, V_val2 As Variant
        If IsMissing(V_Low1) Then
            V_Low1 = LBound(VA_array, 1)
        End If
        If IsMissing(V_high1) Then
            V_high1 = UBound(VA_array, 1)
        End If
        V_Low2 = V_Low1
        V_high2 = V_high1
        V_val1 = VA_array((V_Low1 + V_high1) / 2)
        While (V_Low2 <= V_high2)
            While (VA_array(V_Low2) < V_val1 And _
                V_Low2 < V_high1)
                V_Low2 = V_Low2 + 1
            Wend
            While (VA_array(V_high2) > V_val1 And _
                V_high2 > V_Low1)
                V_high2 = V_high2 - 1
            Wend
            If (V_Low2 <= V_high2) Then
                V_val2 = VA_array(V_Low2)
                VA_array(V_Low2) = VA_array(V_high2)
                VA_array(V_high2) = V_val2
                V_Low2 = V_Low2 + 1
                V_high2 = V_high2 - 1
            End If
        Wend
        If (V_high2 > V_Low1) Then Call _
            QuickSort(VA_array, V_Low1, V_high2)
        If (V_Low2 < V_high1) Then Call _
            QuickSort(VA_array, V_Low2, V_high1)
    End Sub
    
    

    Dialog zur Verzeichnisauswahl

    
    Public Type BROWSEINFO
       hOwner As Long
       pidlRoot As Long
       pszDisplayName As String
       lpszTitle As String
       ulFlags As Long
       lpfn As Long
       lParam As Long
       iImage As Long
    End Type
    
    Declare Function SHGetPathFromIDList Lib "shell32.dll" _
       Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
       ByVal pszPath As String) As Long
    
    Declare Function SHBrowseForFolder Lib "shell32.dll" _
       Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
    
    Function GetDirectory(Optional msg) As String
       Dim bInfo As BROWSEINFO
       Dim Path As String
       Dim r As Long, x As Long, pos As Integer
       bInfo.pidlRoot = 0&
       If IsMissing(msg) Then
          bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus."
       Else
          bInfo.lpszTitle = msg
       End If
       bInfo.ulFlags = &H1
       x = SHBrowseForFolder(bInfo)
       Path = Space$(512)
       r = SHGetPathFromIDList(ByVal x, ByVal Path)
       If r Then
          pos = InStr(Path, Chr$(0))
          GetDirectory = Left(Path, pos - 1)
       Else
          GetDirectory = ""
       End If
    End Function
    

    Auslesen der Dateinamen in einem Verzeichnis

    
    Function FileArray(strPath As String, strPattern As String)
       Dim arrDateien()
       Dim intCounter As Integer
       Dim strDatei As String
       If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
       strDatei = Dir(strPath & strPattern)
       Do While strDatei <> ""
           intCounter = intCounter + 1
           ReDim Preserve arrDateien(1 To intCounter)
           arrDateien(intCounter) = strDatei
           strDatei = Dir()
       Loop
       If intCounter = 0 Then
          ReDim arrDateien(1)
          arrDateien(1) = False
       End If
       FileArray = arrDateien
    End Function
    

    Sortieren der Dateien eines Verzeichnisses nach Dateiname

    
    Sub CallQuickSortFilesA()
       Dim arr As Variant
       Dim intCounter As Integer
       Dim strPath As String
       strPath = GetDirectory("Bitte Verzeichnis auswählen:")
       If strPath = "" Then Exit Sub
       arr = FileArray(strPath, "*.*")
       If arr(1) = False Then
          Beep
          MsgBox "Keine Dateien gefunden!"
          Exit Sub
       End If
       QuickSort arr
       Columns("A:B").ClearContents
       For intCounter = 1 To UBound(arr)
          Cells(intCounter, 1) = arr(intCounter)
       Next intCounter
       Columns(1).AutoFit
    End Sub
    

    Sortieren der Dateien eines Verzeichnisses nach Dateidatum

    
    Sub CallQuickSortFilesB()
       Dim arrDate() As Variant
       Dim arr As Variant
       Dim intCounter As Integer
       Dim strPath As String
       strPath = GetDirectory("Bitte Verzeichnis auswählen:")
       If strPath = "" Then Exit Sub
       arr = FileArray(strPath, "*.*")
       If arr(1) = False Then
          Beep
          MsgBox "Keine Dateien gefunden!"
          Exit Sub
       End If
       Columns("A:B").ClearContents
       ReDim arrDate(1 To 2, 1 To UBound(arr))
       For intCounter = 1 To UBound(arr)
          arrDate(1, intCounter) = arr(intCounter)
          arrDate(2, intCounter) = FileDateTime(strPath & arr(intCounter))
       Next intCounter
       Columns(1).ClearContents
       For intCounter = 1 To UBound(arr)
          Cells(intCounter, 1) = arrDate(1, intCounter)
          Cells(intCounter, 2) = arrDate(2, intCounter)
       Next intCounter
       Range("A1").CurrentRegion.Sort key1:=Range("B1"), _
          order1:=xlAscending, header:=xlNo
       Columns("A:B").AutoFit
    End Sub
    

    Sortieren der Arbeitsblätter der aktiven Arbeitsmappe

    
    Sub CallQuickSortWks()
       Dim arr() As String
       Dim intCounter As Integer
       ReDim arr(1 To Worksheets.Count)
       For intCounter = 1 To Worksheets.Count
          arr(intCounter) = Worksheets(intCounter).Name
       Next intCounter
       QuickSort arr
       For intCounter = UBound(arr) To 1 Step -1
          Worksheets(arr(intCounter)).Move before:=Worksheets(1)
       Next intCounter
    End Sub
    

    Sortieren einer Tabelle nach einer benutzerdefinierten Sortierfolge

    
    Sub SortBasedOnCustomList()
       Application.AddCustomList ListArray:=Range("B2:B14")
       Range("A16:B36").Sort _
          key1:=Range("B17"), _
          order1:=xlAscending, _
          header:=xlYes, _
          OrderCustom:=Application.CustomListCount + 1
       Application.DeleteCustomList Application.CustomListCount
    End Sub
    

    Sortieren einer Datums-Tabelle ohne Einsatz der Excel-Sortierung

    
    Sub CallQuickSortDate()
       Dim arr(1 To 31) As Date
       Dim intRow As Integer
       For intRow = 2 To 32
          arr(intRow - 1) = Cells(intRow, 1)
       Next intRow
       Call QuickSort(arr)
       For intRow = 2 To 32
          Cells(intRow, 1).Value = arr(intRow - 1)
       Next intRow
    End Sub
    

    Sortieren einer Tabelle nach sechs Sortierkriterien

    
    Sub SortSixColumns()
       Dim intCounter As Integer
       For intCounter = 2 To 1 Step -1
          Range("A1").CurrentRegion.Sort _
             key1:=Cells(1, intCounter * 3 - 2), _
             order1:=xlAscending, _
             key2:=Cells(1, intCounter * 3 - 1), _
             order2:=xlAscending, _
             key3:=Cells(1, intCounter * 3), _
             order3:=xlAscending, _
             header:=xlNo
       Next intCounter
    End Sub
    

    Sortieren mit Ae vor Ä und Sch vor S

    
    Sub SpecialSort()
       With Columns("A")
          .Replace What:="Ä", Replacement:="Ae", LookAt:=xlPart, SearchOrder _
              :=xlByRows, MatchCase:=True
          .Replace What:="Sch", Replacement:="Rzz", LookAt:=xlPart, _
              SearchOrder:=xlByRows, MatchCase:=True
          .Sort key1:=Range("A2"), order1:=xlAscending, header:=xlGuess, _
              OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
          .Replace What:="Rzz", Replacement:="Sch", LookAt:=xlPart, _
              SearchOrder:=xlByRows, MatchCase:=True
          .Replace What:="Ae", Replacement:="Ä", LookAt:=xlPart, SearchOrder _
               :=xlByRows, MatchCase:=True
       End With
    End Sub
    

    Sortieren nach der Häufigkeit des Vorkommens

    
    Sub CountIfSort()
       Dim intRow As Integer, intCounter As Integer, intArr As Integer
       Range("A1").Sort key1:=Range("A1"), order1:=xlAscending, header:=xlNo
       Range("B1").Formula = "=countif(A:A,A1)"
       Range("B1:B" & Range("A1").CurrentRegion.Rows.Count).FillDown
       Range("A1").Sort key1:=Range("B1"), order1:=xlDescending, header:=xlNo
       Columns("B").ClearContents
    End Sub
    

    Sortieren einschließlich der ausgeblendeten Zeilen

    
    Sub SortAll()
       Dim rngHidden As Range
       Dim lngLastRow As Long, lngRow As Long
       Application.ScreenUpdating = False
       Set rngHidden = Rows(1)
       lngLastRow = Cells(Rows.Count, 1).End(xlUp).Row
       For lngRow = 1 To lngLastRow
          If Rows(lngRow).Hidden = True Then
             Set rngHidden = Union(rngHidden, Rows(lngRow))
          End If
       Next lngRow
       rngHidden.EntireRow.Hidden = False
       Range("A1").CurrentRegion.Sort key1:=Range("A2"), _
          order1:=xlAscending, header:=xlYes
       rngHidden.EntireRow.Hidden = True
       Rows(1).Hidden = False
       Application.ScreenUpdating = True
    End Sub
    

    Sortieren mehrerer Tabellenblattbereiche

    
    Sub MultiSort()
       Dim intRow As Integer
       For intRow = 1 To 19 Step 6
          Range(Cells(intRow, 1), Cells(intRow + 4, 8)).Sort _
             key1:=Cells(intRow + 1, 7), _
             order1:=xlAscending, header:=xlYes
       Next intRow
    End Sub
    

    Direkter Aufruf des Sortierdialogs

    
    Sub CallSortDialogA()
       Application.Dialogs(xlDialogSort).Show
    End Sub
    

    Aufruf des Sortierdialogs unter Einsatz der Sortier-Schaltfläche

    
    Sub CallSortDialogB()
       Range("A1").Select
       CommandBars.FindControl(ID:=928).Execute
    End Sub