'entwickelt von Winfried Radner 'e-mail: Wolf.W.Radzinski@onlinehome.de 'Benutzung frei - ohne Gewähr 'Quicksort für Excel Collections Sub quicksort_in_(quelle As Range, Optional blanks = True, Optional up = True) Dim r As Range, z As Range Dim a As Range Dim c As New Collection Set r = ActiveSheet.UsedRange Set r = Intersect(r, quelle) If r Is Nothing Then Exit Sub For Each a In r.Areas For Each z In a If blanks Or z <> "" Then c.Add z End If Next z Next a If c.Count = 0 Then Exit Sub If up Then collection_quick_sort c, 1, c.Count Else collection_quick_sort_down c, 1, c.Count End If MsgBox c.Count & " sortierte Zellinhalte" Set c = Nothing End Sub Sub collection_quick_sort(c As Collection, ByVal lo As Long, ByVal hi As Long) i = lo j = hi m = CLng((lo + hi) / 2) x = c.Item(m) Do While i <= j Do While c.Item(i) < x i = i + 1 Loop Do While c.Item(j) > x j = j - 1 Loop If i <= j Then temp = c.Item(i) c.Item(i) = c.Item(j) c.Item(j) = temp i = i + 1 j = j - 1 End If Loop If lo < j Then collection_quick_sort c, lo, j If i < hi Then collection_quick_sort c, i, hi End Sub Sub collection_quick_sort_down(c As Collection, ByVal lo As Long, ByVal hi As Long) i = lo j = hi m = CLng((lo + hi) / 2) x = c.Item(m) Do While i <= j Do While c.Item(i) > x i = i + 1 Loop Do While c.Item(j) < x j = j - 1 Loop If i <= j Then temp = c.Item(i) c.Item(i) = c.Item(j) c.Item(j) = temp i = i + 1 j = j - 1 End If Loop If lo < j Then collection_quick_sort_down c, lo, j If i < hi Then collection_quick_sort_down c, i, hi End Sub Sub test_up() 'ActiveSheet.Unprotect quicksort_in_ Selection, False 'ActiveSheet.Protect End Sub Sub test_down() 'ActiveSheet.Unprotect quicksort_in_ Selection, False, False 'ActiveSheet.Protect End Sub