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
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
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
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
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
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
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
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
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
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
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
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
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
Sub CallSortDialogA()
Application.Dialogs(xlDialogSort).Show
End Sub
Sub CallSortDialogB()
Range("A1").Select
CommandBars.FindControl(ID:=928).Execute
End Sub