'entwickelt von Winfried Radner
'e-mail: Wolf.W.Radzinski@onlinehome.de
'Benutzung frei - ohne Gewähr


Sub test()
'test der Prozedur sortieren2
'sortiert wird der Bereich Minimum aus
'Spalte A bis E bzw Selection und Usedrange
'Sortierreihenfolge = (key1,key2,...,keyn)
'Spalte F liegt ausserhalb der Selection
'd.h. der Parameter 6 wird nicht beachtet!
'Spalte C aufsteigend
'Spalte A aufsteigend
'Spalte B absteigend
'Spalte D aufsteigend
  Columns("A:E").Select
  sortieren2 6, 3, 1, -2, 4
End Sub


Sub sortieren()
'Sortierspalten werden in eine Inputbox eingegeben
'aufsteigende Sortierung = Spaltennummer positiv z.B. 1 2 3
'absteigende Sortierung = Spaltennummer negativ z.B. -1 -2 -3
'Sortierreihenfolge = (key1 key2 ... keyn)
'Trennzeichen zwischen den Parametern ist das LEERZEICHEN
On Error Resume Next
   Dim a As Range
   Dim pl() As Variant
   parameterliste = InputBox("Spaltenreihenfolge") & " "
   l = Len(parameterliste)
   i = -1
   Do
      pos = InStr(1, parameterliste, " ")
      If pos > 1 Then
       i = i + 1
       ReDim Preserve pl(i)

       pl(i) = CInt(Left(parameterliste, pos - 1))
       parameterliste = Right(parameterliste, l - pos)
       l = l - pos
      End If
   Loop Until pos < 2
   If i >= 0 Then Call sort_it(pl())
End Sub

Sub sortieren_c()
'Sortierspalten werden in eine Inputbox eingegeben
'aufsteigende Sortierung = Spalte z.B. A b C
'absteigende Sortierung = -Spalte z.B. -A -b -C
'Sortierreihenfolge = (key1 key2 ... keyn)
'Trennzeichen zwischen den Parametern ist das LEERZEICHEN
On Error Resume Next
   Dim a As Range
   Dim pl() As Variant
   parameterliste = InputBox("Spaltenreihenfolge") & " "
   l = Len(parameterliste)
   i = -1
   Do
      pos = InStr(1, parameterliste, " ")
      If pos > 1 Then
       i = i + 1
       ReDim Preserve pl(i)

       temp = Left(parameterliste, pos - 1)
       If Left(temp, 1) = "-" Then
          vz = -1
          temp = Right(temp, Len(temp) - 1)
          Else
          vz = 1
          End If
       temp = Columns(temp).Column
       pl(i) = vz * temp
       parameterliste = Right(parameterliste, l - pos)
       l = l - pos
      End If
   Loop Until pos < 2
   If i >= 0 Then Call sort_it(pl())
End Sub

Sub sortieren2(ParamArray pl() As Variant)
'Sortierspalten werden als Parameter der Funktion übergeben
'aufsteigende Sortierung = Spaltennummer positiv
'absteigende Sortierung = Spaltennummer negativ
'Sortierreihenfolge = (key1,key2,...,keyn)
'Trennzeichen zwischen den Parametern ist das KOMMA
Dim plist() As Variant
anz = UBound(pl())
If anz < 0 Then Exit Sub
ReDim plist(anz)
For i = 0 To anz
plist(i) = pl(i)
Next i
Call sort_it(plist())
End Sub


Private Sub sort_it(paralist() As Variant)
On Error Resume Next
   u_ind = UBound(paralist)
   ar = ActiveCell.Row
   ac = ActiveCell.Column
   sr = Selection.Row + Selection.Rows.Count - 1
   sc = Selection.Column + Selection.Columns.Count - 1
   ur = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
   uc = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1
   sr = WorksheetFunction.Min(sr, ur)
   sc = WorksheetFunction.Min(sc, uc)
   Range(Cells(ar, ac), Cells(sr, sc)).Select
   For i = u_ind To 0 Step -1
      If Abs(paralist(i)) < ac Or Abs(paralist(i)) > sc Then
         GoTo next_i
      Else
        If paralist(i) > 0 Then
          Selection.Sort Key1:=Cells(1, paralist(i)), Order1:=xlAscending, Header:=xlGuess, _
          OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        Else
          Selection.Sort Key1:=Cells(1, Abs(paralist(i))), Order1:=xlDescending, Header:=xlGuess, _
          OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        End If
      End If
next_i:
   Next i
End Sub