Sortieren

Hallo,
ich habe im Tabellenblatt "Basis" in Spalte 4 bestimmte
Werte stehen (N1, N2, N3 .... N1000 usw), die jeweils nur einmal
in der Spalte 4 vorkommen (andere Werte gibt es in dieser spalte nicht).
Jedoch steht nicht in jeder Zelle der Spalte 4 einer dieser Werte.
Jetzt möchte ich diese Werte in Spalte 4 gerne mit einem Button (cmdSortieren)
Sortieren lassen (aufsteigend).
Problem dabei ist, dass die neue Zuordnung genau in die Zellen in spalte 4 geschreiben
werden muss, wo bereits die alten Werte standen.
Beispiel (Spalte 4):
D3 = N5
D4 = N2
D47 = N4
D187 = N1
D2317 = N3
Nach Klick auf den Sortierbutton müssen die Zellen in Spalte 4 folgende Werte besitzen:
D3 = N1
D4 = N2
D47 = N3
D187 = N4
D2317 = N5
Bin für jede Hilfe dankbar!!!
Thomas

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Sortieren

04.02.2007 22:07:45

Josef

AW: Sortieren

04.02.2007 22:38:52

Thomas

Hallo Thomas,
probier mal diesen Code.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub SortInPlace()
    Dim vTmp As Variant, vVal() As Variant, vRows() As Long
    Dim lngRow As Long, lngIndex As Long


    vTmp = Range("D2:D" & Cells(Rows.Count, 4).End(xlUp).Row)

    For lngRow = 1 To UBound(vTmp, 1)
        If vTmp(lngRow, 1) <> Empty Then
            Redim Preserve vVal(lngIndex)
            Redim Preserve vRows(lngIndex)
            vVal(lngIndex) = Clng(Mid(vTmp(lngRow, 1), 2))
            vRows(lngIndex) = lngRow
            lngIndex = lngIndex + 1
        End If
    Next

    If lngIndex > 0 Then
        QuickSort vVal
    Else
        Exit Sub
    End If

    For lngRow = 0 To UBound(vRows)
        vTmp(vRows(lngRow), 1) = "N" & vVal(lngRow)
    Next

    Range("D2:D" & Cells(Rows.Count, 4).End(xlUp).Row) = vTmp


End Sub

Sub QuickSort(data() As Variant, Optional UG, Optional OG)
    Dim P1&, P2&, T1 As Variant, T2 As Variant

    UG = IIf(IsMissing(UG), LBound(data), UG)
    OG = IIf(IsMissing(OG), UBound(data), OG)

    P1 = UG
    P2 = OG
    T1 = data((P1 + P2) / 2)

    Do

        Do While (data(P1) < T1)
            P1 = P1 + 1
        Loop

        Do While (data(P2) > T1)
            P2 = P2 - 1
        Loop

        If P1 <= P2 Then
            T2 = data(P1)
            data(P1) = data(P2)
            data(P2) = T2
            P1 = P1 + 1
            P2 = P2 - 1
        End If

    Loop Until (P1 > P2)

    If UG < P2 Then QuickSort data, UG, P2
    If P1 < OG Then QuickSort data, P1, OG

End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread