unabhängig Spalten sortieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub test() Dim S As Long With ActiveSheet.UsedRange .Sort key1:=.Cells(2, 1), order1:=xlAscending, Header:=xlNo, Orientation:=2 With .Offset(2, 0).Resize(.Rows.Count - 2, 2) For S = 1 To WorksheetFunction.Count(Rows(2)) Step 2 .Columns(S).Resize(, 2).Select .Columns(S).Resize(, 2).Sort key1:=.Cells(1, S), order1:=xlAscending, Header:=xlNo, _ Orientation:=1 Next End With .Sort key1:=.Cells(1, 1), order1:=xlAscending, Header:=xlNo, Orientation:=2 End With End Sub

Hallo Roman,
teste mal:

Option Explicit

Public Sub Sorting()

    Const COLUMN_OFFSET As Long = 250

    Dim avntValues1 As Variant, avntValues2 As Variant
    Dim lngColumn As Long, lngLastRow As Long

    lngColumn = Selection.Column

    lngLastRow = Cells(Rows.Count, lngColumn).End(xlUp).Row
    lngLastRow = Application.Max(lngLastRow, Cells(Rows.Count, lngColumn + COLUMN_OFFSET).End(xlUp).Row)

    avntValues1 = Range(Cells(1, lngColumn), Cells(lngLastRow, lngColumn)).Value
    avntValues2 = Range(Cells(1, lngColumn + COLUMN_OFFSET), Cells(lngLastRow, lngColumn + COLUMN_OFFSET)).Value

    Call QuickSort(1, lngLastRow, avntValues1, avntValues2)

    Range(Cells(1, lngColumn), Cells(lngLastRow, lngColumn)).Value = avntValues1
    Range(Cells(1, lngColumn + COLUMN_OFFSET), Cells(lngLastRow, lngColumn + COLUMN_OFFSET)).Value = avntValues2

End Sub

Private Sub QuickSort(ByVal pvlngLBound As Long, ByVal pvlngUBound As Long, _
        ByRef avntValuses1 As Variant, ByRef avntValuses2 As Variant)

    Dim ialngIndex1 As Long, ialngIndex2 As Long
    Dim vntElement As Variant, vntBuffer As Variant

    ialngIndex1 = pvlngLBound
    ialngIndex2 = pvlngUBound

    vntBuffer = avntValuses1((pvlngLBound + pvlngUBound) \ 2, 1)

    Do

        Do While avntValuses1(ialngIndex1, 1) < vntBuffer
            ialngIndex1 = ialngIndex1 + 1
        Loop

        Do While vntBuffer < avntValuses1(ialngIndex2, 1)
            ialngIndex2 = ialngIndex2 - 1
        Loop

        If ialngIndex1 <= ialngIndex2 Then

            vntElement = avntValuses1(ialngIndex1, 1)
            avntValuses1(ialngIndex1, 1) = avntValuses1(ialngIndex2, 1)
            avntValuses1(ialngIndex2, 1) = vntElement

            vntElement = avntValuses2(ialngIndex1, 1)
            avntValuses2(ialngIndex1, 1) = avntValuses2(ialngIndex2, 1)
            avntValuses2(ialngIndex2, 1) = vntElement

            ialngIndex1 = ialngIndex1 + 1
            ialngIndex2 = ialngIndex2 - 1

        End If
    Loop Until ialngIndex1 > ialngIndex2

    If pvlngLBound < ialngIndex2 Then Call QuickSort(pvlngLBound, ialngIndex2, avntValuses1, avntValuses2)
    If ialngIndex1 < pvlngUBound Then Call QuickSort(ialngIndex1, pvlngUBound, avntValuses1, avntValuses2)

End Sub

Einfach den Cursor in die gewünschte Spalte setzen und dann das Makro "Sorting" aufrufen (Alt+F8).
Gruß
Nepumuk

Hallo Roman,
teste mal:

Option Explicit

Public Sub Sorting()

    Const COLUMN_OFFSET As Long = 250

    Dim avntValues1 As Variant, avntValues2 As Variant
    Dim lngColumn As Long, lngLastRow As Long

    For lngColumn = 1 To COLUMN_OFFSET

        lngLastRow = Cells(Rows.Count, lngColumn).End(xlUp).Row
        lngLastRow = Application.Max(lngLastRow, Cells(Rows.Count, lngColumn + COLUMN_OFFSET).End(xlUp).Row)

        avntValues1 = Range(Cells(1, lngColumn), Cells(lngLastRow, lngColumn)).Value
        avntValues2 = Range(Cells(1, lngColumn + COLUMN_OFFSET), Cells(lngLastRow, lngColumn + COLUMN_OFFSET)).Value

        If Not IsEmpty(avntValues1) Then

            Call ClearErrors(avntValues1)
            Call ClearErrors(avntValues2)

            Call QuickSort(1, lngLastRow, avntValues1, avntValues2)

            Range(Cells(1, lngColumn), Cells(lngLastRow, lngColumn)).Value = avntValues1
            Range(Cells(1, lngColumn + COLUMN_OFFSET), Cells(lngLastRow, lngColumn + COLUMN_OFFSET)).Value = avntValues2

        End If
    Next
End Sub

Private Sub QuickSort(ByVal pvlngLBound As Long, ByVal pvlngUBound As Long, _
        ByRef avntValuses1 As Variant, ByRef avntValuses2 As Variant)

    Dim ialngIndex1 As Long, ialngIndex2 As Long
    Dim vntElement As Variant, vntBuffer As Variant

    ialngIndex1 = pvlngLBound
    ialngIndex2 = pvlngUBound

    vntBuffer = avntValuses1((pvlngLBound + pvlngUBound) \ 2, 1)

    Do

        Do While avntValuses1(ialngIndex1, 1) < vntBuffer
            ialngIndex1 = ialngIndex1 + 1
        Loop

        Do While vntBuffer < avntValuses1(ialngIndex2, 1)
            ialngIndex2 = ialngIndex2 - 1
        Loop

        If ialngIndex1 <= ialngIndex2 Then

            vntElement = avntValuses1(ialngIndex1, 1)
            avntValuses1(ialngIndex1, 1) = avntValuses1(ialngIndex2, 1)
            avntValuses1(ialngIndex2, 1) = vntElement

            vntElement = avntValuses2(ialngIndex1, 1)
            avntValuses2(ialngIndex1, 1) = avntValuses2(ialngIndex2, 1)
            avntValuses2(ialngIndex2, 1) = vntElement

            ialngIndex1 = ialngIndex1 + 1
            ialngIndex2 = ialngIndex2 - 1

        End If
    Loop Until ialngIndex1 > ialngIndex2

    If pvlngLBound < ialngIndex2 Then Call QuickSort(pvlngLBound, ialngIndex2, avntValuses1, avntValuses2)
    If ialngIndex1 < pvlngUBound Then Call QuickSort(ialngIndex1, pvlngUBound, avntValuses1, avntValuses2)

End Sub

Private Sub ClearErrors(ByRef pravntValues As Variant)

    Dim ialngIndex As Long

    For ialngIndex = LBound(pravntValues) To UBound(pravntValues)

        If IsError(pravntValues(ialngIndex, 1)) Then

            Select Case pravntValues(ialngIndex, 1)
                Case CVErr(xlErrDiv0)
                    pravntValues(ialngIndex, 1) = "#DIV/0!"
                Case CVErr(xlErrNA)
                    pravntValues(ialngIndex, 1) = "#N/A"
                Case CVErr(xlErrName)
                    pravntValues(ialngIndex, 1) = "#NAME?"
                Case CVErr(xlErrNull)
                    pravntValues(ialngIndex, 1) = "#NULL!"
                Case CVErr(xlErrNum)
                    pravntValues(ialngIndex, 1) = "#NUM!"
                Case CVErr(xlErrRef)
                    pravntValues(ialngIndex, 1) = "#REF!"
                Case CVErr(xlErrValue)
                    pravntValues(ialngIndex, 1) = "#VALUE!"
            End Select
        End If
    Next
End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

26 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

26
Beiträge zum Forumthread

Beiträge zu diesem Forumthread