Wikibooks

VBA in Excel/ Sortieren

< VBA in Excel


Auf die folgenden 3 Codes greifen mehrere der Sortierprogramme zu:

Schnelle VBA-Sortierroutine

Bearbeiten

Autor: John Green 

Sub QuickSort(ByRef VA_array, Optional V_Low1, Optional V_High1)   
    Dim V_Low2 As Long, V_High2 As Long
    Dim V_val1 As Variant, 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

Bearbeiten 
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

Bearbeiten 
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

Bearbeiten 
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

Bearbeiten 
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

Bearbeiten 
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

Bearbeiten 
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

Bearbeiten 
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

Bearbeiten 
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

Bearbeiten 
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

Bearbeiten

Sortieren einschließlich der ausgeblendeten Zeilen

Bearbeiten 
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

Bearbeiten 
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

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

Aufruf des Sortierdialogs unter Einsatz der Sortier-Schaltfläche

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

Sortieren per Matrixfunktion

Bearbeiten

Author: Stefan Karrmann 

Function MatrixSort(ByRef arr As Variant, ByVal column As Long) As Variant()
    MatrixSort = arr.Value2
    Call QuickSortCol(MatrixSort, column)
End Function

Sub QuickSortCol(ByRef VA_array, Optional ByVal column As Long, _
                Optional V_Low1, Optional V_high1)
    ' On Error Resume Next
    Dim V_Low2, V_high2, V_loop As Integer
    Dim V_val1 As Variant
    Dim tmp As Variant
    Dim ColLow As Long, colHigh As Long, col As Long
    
    If IsMissing(column) Then
        column = 1
    End If
    
    ColLow = LBound(VA_array, 2)
    colHigh = UBound(VA_array, 2)
    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, column)
    While (V_Low2 <= V_high2)
        While (V_Low2 < V_high1 _
           And VA_array(V_Low2, column) < V_val1)
            V_Low2 = V_Low2 + 1
        Wend
        While (V_high2 > V_Low1 _
           And VA_array(V_high2, column) > V_val1)
            V_high2 = V_high2 - 1
        Wend
        If (V_Low2 <= V_high2) Then
            For col = ColLow To colHigh
                tmp = VA_array(V_Low2, col)
                VA_array(V_Low2, col) = VA_array(V_high2, col)
                VA_array(V_high2, col) = tmp
            Next col
            V_Low2 = V_Low2 + 1
            V_high2 = V_high2 - 1
        End If
    Wend
    If (V_high2 > V_Low1) Then Call _
        QuickSortCol(VA_array, column, V_Low1, V_high2)
    If (V_Low2 < V_high1) Then Call _
        QuickSortCol(VA_array, column, V_Low2, V_high1)
End Sub

Stringfolge sortieren

Bearbeiten

Author: Markus Wilmes 

Sub DemoStrSort()
   Dim strSort As String
   strSort = "ak dv ad sf ad fa af dd da fa d1 25 24 ad fx "
   Call QuickSortStr(strSort, 3)
   MsgBox strSort
End Sub

Sub QuickSortStr(ByRef strToSort As String, Optional ByVal lngLen, Optional ByVal lngLow, Optional ByVal lngHigh)
   Dim lngCLow  As Long
   Dim lngCHigh As Long
   Dim lngPos   As Long
   Dim varA     As Variant
   Dim varB     As Variant
   If IsMissing(lngLen) Then
      lngLen = 1
   End If
   If IsMissing(lngLow) Then
      lngLow = 0
   End If
   If IsMissing(lngHigh) Then
      lngHigh = (Len(strToSort) / lngLen) - 1
   End If
   lngCLow = lngLow
   lngCHigh = lngHigh
   lngPos = Int((lngLow + lngHigh) / 2)
   varA = Mid(strToSort, (lngPos * lngLen) + 1, lngLen)
   While (lngCLow <= lngCHigh)
      While (Mid(strToSort, (lngCLow * lngLen) + 1, lngLen) < varA And lngCLow < lngHigh)
         lngCLow = lngCLow + 1
      Wend
      While (Mid(strToSort, (lngCHigh * lngLen) + 1, lngLen) > varA And lngCHigh > lngLow)
         lngCHigh = lngCHigh - 1
      Wend
      If (lngCLow <= lngCHigh) Then
         varB = Mid(strToSort, (lngCLow * lngLen) + 1, lngLen)
         Mid(strToSort, (lngCLow * lngLen) + 1, lngLen) = Mid(strToSort, (lngCHigh * lngLen) + 1, lngLen)
         Mid(strToSort, (lngCHigh * lngLen) + 1, lngLen) = varB
         lngCLow = lngCLow + 1
         lngCHigh = lngCHigh - 1
      End If
   Wend
   If (lngCHigh > lngLow) Then
      Call QuickSortStr(strToSort, lngLen, lngLow, lngCHigh)
   End If
   If (lngCLow < lngHigh) Then
      Call QuickSortStr(strToSort, lngLen, lngCLow, lngHigh)
   End If
End Sub
Abgerufen von „https://de.wikibooks.org/w/index.php?title=VBA_in_Excel/_Sortieren&oldid=657372“