Microsoft Excel

Excel und VBA: Formeln, Programmierung, Lösungen

Inhalt dieser Seite

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