Spezielles Sortieren über VBA

Jem · 2022-10-04T07:12:23+00:00

Moin, ich hatte schonmal eine Anfrage gestartet hier im Forum, kann jedoch auf den alten Thread nicht antworten (Cookie-Fehler). Also zu meinem Problem: Eine Tabelle mit 5 Spalten soll mit Werten aus der Spalte A sortiert werden, absteigend. Jedoch sollen z.B. 3 -Stellige Zellen nach oben sortiert werden und 4 Stellige Zellen darunter. Wichtig ist auch das es dynamisch funktionieren muss. Also die Anzahl der Reihen kann variieren. Beispiel: Spalte A | Spalte B | Spalte C | Spalte D | Spalte E 1-005 | 06:00 Uhr | 14:00 Uhr | Adresse1 | Adresse 2 001 | 12:00 Uhr | 20:00 Uhr | Adresse1 | Adresse 2 101 | 09:00 Uhr | 15:00 Uhr | Adresse1 | Adresse 2 103 | 09:00 Uhr | 15:00 Uhr | Adresse1 | Adresse 2 003 | 12:00 Uhr | 20:00 Uhr | Adresse1 | Adresse 2 1-006 | 06:00 Uhr | 14:00 Uhr | Adresse1 | Adresse 2 Ich habe einen Ansatz aus dem ersten Thread, dieser ist leider nicht dynamisch und sortiert nur die erste Spalte (A) Option Explicit Option Base 1 Sub sort() Dim arr3(9), arrX(9), x&, a&, b& x = 1: a = 1: b = 1 For x = 1 To 9 If Len(Cells(x, 1)) = 3 Then arr3(a) = Cells(x, 1) a = a + 1 End If If Len(Cells(x, 1)) > 3 Then arrX(b) = Cells(x, 1) b = b + 1 End If Next x Range("A1").Resize(a - 1) = WorksheetFunction.Transpose(arr3) Cells(a, 1).Resize(b - 1) = WorksheetFunction.Transpose(arrX) End Sub Vielen Dank für die Hilfe!

Hallo Jem
Mit einem Rechtsklick auf Zelle A1
Dieser Code gehört ins Modul des Arbeitsblattes


Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If ActiveCell  Range("A1") Then Exit Sub
Dim letztZ As Long, letztS As Integer, i As Long, j As Long, AnzZeich As Integer
Application.ScreenUpdating = False
letztZ = Range("A100000").End(xlUp).Row
letztS = Selection.SpecialCells(xlCellTypeLastCell).Column + 1
For i = 2 To letztZ
AnzZeich = Len(Cells(i, 1))
Cells(i, letztS) = AnzZeich
Next
DoEvents
ActiveWorkbook.Worksheets("Tabelle1").sort.SortFields.Clear
ActiveWorkbook.Worksheets("Tabelle1").sort.SortFields.Add2 Key:=Cells( _
2, letztS), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Tabelle1").sort
.SetRange Range(Cells(1, 1), Cells(letztZ, letztS))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
DoEvents
Application.CutCopyMode = False
ActiveWorkbook.Worksheets("Tabelle1").sort.SortFields.Clear
ActiveWorkbook.Worksheets("Tabelle1").sort.SortFields.Add2 Key:=Cells( _
2, letztS), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Tabelle1").sort
.SetRange Range(Cells(1, 1), Cells(letztZ, letztS))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Columns(letztS).Delete Shift:=xlToLeft
[A1].Select
Application.ScreenUpdating = True
ActiveWorkbook.Save
End Sub

Gruss werni

Forumthread: Spezielles Sortieren über VBA

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial