AW: Sortierung erweitern.
30.09.2019 15:12:36
Matthias
Moin!
Lege mal am Anfang noch eine private Variable sortkrit an. ALso die Zeile einfügen.
Private sortkrit As String
Und dann tausche dein MousUpEvent damit.
Private Sub lblSort_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, _
ByVal Y As Single)
Dim astrColumnWidth() As String
Dim iastrCW As Long
Dim sngColumnWidth As Single
Dim sngSum As Single
Dim i As Long
Dim lngFieldIndex As Long
Dim kritliste
Dim lngSortOrder As XlSortOrder
'If datenberech.ListRows.Count = 0 Then Exit Sub
Select Case Button
Case 1: lngSortOrder = xlAscending
Case 2: lngSortOrder = xlDescending
Case Else: Exit Sub
End Select
astrColumnWidth() = Split(Replace(ListBox1.ColumnWidths, " Pt", ""), ";")
For iastrCW = LBound(astrColumnWidth) To UBound(astrColumnWidth)
sngColumnWidth = CSng(astrColumnWidth(iastrCW))
sngSum = sngSum + sngColumnWidth
If sngSum >= X Then lngFieldIndex = iastrCW: Exit For
Next
' If lngFieldIndex > 0 Then
' With datenberech.Range
' .Sort .Cells(1, lngFieldIndex + 1), lngSortOrder, Header:=xlYes
' End With
' ' Call GetFilterData(Listbox1, lblFilterCount)
' End If
Dim iLSpalte As Integer ' die letzte belegte Spalte in Zeile 1 'xlAscending xlDescending
Dim lLZeile As Long ' die letzte belegte Zeile in Spalte A
Dim Spaltennummer1
Dim Spaltennummer2
Spaltennummer1 = lngFieldIndex
Dim sortrichtung As Integer
'If aufsteigend = False And absteigend = False Then
'MsgBox " Achtung soll ich absteigend oder austeigend sortieren. Bitt setz den Hacken."
'Exit Sub
'End If
'If absteigend.Value = True Then
sortrichtung = lngSortOrder 'xlDescending
'Spaltennummer1 = CB_suchspalten.ListIndex + 1
'Spaltennummer2 = CB_suchspalten2.ListIndex + 1
MsgBox Spaltennummer1
With Tabelle1
lLZeile = .Cells(Rows.Count, 1).End(xlUp).Row
iLSpalte = .Cells(1, Columns.Count).End(xlToLeft).Column
sortkrit = sortkrit & ";" & Spaltennummer1 & "@" & sortrichtung
'MsgBox CB_suchspalten2.ListIndex
'If CB_suchspalten2.ListIndex = -1 Then
.Sort.SortFields.Clear
kritliste = Split(sortkrit, ";")
For i = 1 To UBound(kritliste)
Debug.Print Split(kritliste(i), "@")(0)
.Sort.SortFields.Add Key:=.Range(.Cells(2, CLng(Split(kritliste(i), "@")(0))), .Cells(lLZeile, _
CLng(Split(kritliste(i), "@")(0)))), _
SortOn:=xlSortOnValues, Order:=Split(kritliste(i), "@")(1), DataOption:=xlSortNormal
Next
With .Sort
.SetRange Tabelle1.Range(Tabelle1.Cells(1, 1), Tabelle1.Cells(lLZeile, iLSpalte))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
End Sub
Hiermit wird die Speicherung gespeichert und neu gesetzt. Ist jett aber nicht auf 3 Durchläufe begrenzt.
VG