Liste automatisch sortieren nach Eintrag

Bild

Betrifft: Liste automatisch sortieren nach Eintrag von: Silke
Geschrieben am: 19.02.2005 19:24:03

Hallo,

ich habe folgendes Problem. Ich habe eine Liste
in Spalte A stehen die die Zahlen 1-60, in C 61-120, in E 121-180 etc.
in den den Spalten B,D,F .. steht Text, ich möchte das in diesen Spalten nun der Text alphabetisch sortiert wird. Und zwar so das ich wenn ich Text in Spalte F eingebe und sie eigentlich nach der Sortierreihenfolge in Spalte B oder D gehört das sich der Text automatisch dorthin sortiert. Die Zahlen sollen unverändert bleiben jedoch immer um 1 hochgezählt werden wenn in der Spalte rechts daneben etwas steht.
Ich hoffe ihr könnt mir helfen
Gruss
Silke

Bild


Betrifft: AW: Liste automatisch sortieren nach Eintrag von: Udo
Geschrieben am: 19.02.2005 19:32:37

Ganz schöner Aufwand, lad mal eine Mustertabelle hoch.

Udo


Bild


Betrifft: AW: Liste automatisch sortieren nach Eintrag von: Silke
Geschrieben am: 19.02.2005 19:42:19

Hallo,

hier ist eine kleine Tabelle erstmal

https://www.herber.de/bbs/user/18357.xls

es würde mir schon genügen wenn die ersten zwei Spalten so funtionieren würden

Gruss
Silke


Bild


Betrifft: AW: Liste automatisch sortieren nach Eintrag von: Nepumuk
Geschrieben am: 19.02.2005 21:07:34

Hallo Silke,

Rechtsklick auf den Tabellenreiter - Code anzeigen. Folgendes Makro in das sich öffnende Editorfenster kopieren:


Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Call prcDoIt
End Sub


In der Menüleiste des Editors unter Einfügen - Modul ein Standardmodul einfügen. In dieses folgenden Code kopieren:


Option Explicit

Private Declare Function SafeArrayGetDim Lib "oleaut32" (pArray() As Any) As Long

Public Sub prcDoIt()
    Dim bolExit As Boolean
    Dim intCalculation As Integer, intColumn As Integer, intCount As Integer
    Dim intIndex1 As Integer, intIndex2 As Integer
    Dim lngIndex As Long, lngRow As Long
    Dim varSortArray() As Variant, varArray() As Variant
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
        intCalculation = .Calculation
        .Calculation = -4135
    End With
    For intColumn = 256 To Step -2
        If Cells(Rows.Count, intColumn).End(-4162).Row >= 2 Then
            intCount = intCount + 1
            ReDim Preserve varArray(1 To intCount)
            varArray(intCount) = Range(Cells(2, intColumn), _
                Cells(Cells(Rows.Count, intColumn).End(-4162).Row, intColumn))
        End If
    Next
    On Error Resume Next
    For intIndex1 = 1 To intCount
        If Trim(varArray(intIndex1)) = " " Then
            For intIndex2 = 1 To UBound(varArray(intIndex1))
                If Trim(varArray(intIndex1)(intIndex2, 1)) <> "" Then
                    lngIndex = lngIndex + 1
                    ReDim Preserve varSortArray(1 To lngIndex)
                    varSortArray(lngIndex) = Trim(varArray(intIndex1)(intIndex2, 1))
                End If
            Next
        Else
            If Trim(varArray(intIndex1)) <> "" Then
                lngIndex = lngIndex + 1
                ReDim Preserve varSortArray(1 To lngIndex)
                varSortArray(lngIndex) = Trim(varArray(intIndex1))
            End If
        End If
    Next
    On Error GoTo 0
    Call prcSort(1, lngIndex, varSortArray())
    Cells.Clear
    intIndex1 = 0
    For intColumn = 1 To 255 Step 2
        Cells(1, intColumn).Value = "Nr"
        Cells(1, intColumn + 1).Value = "Titel"
        If bolExit Then Exit For
        intIndex2 = 1
        Do Until intIndex1 = lngIndex Or intIndex2 = 61
            intIndex1 = intIndex1 + 1
            intIndex2 = intIndex2 + 1
            Cells(intIndex2, intColumn).Value = intIndex1
            Cells(intIndex2, intColumn + 1).Value = varSortArray(intIndex1)
        Loop
        If intIndex1 = lngIndex Then bolExit = True
    Next
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
        .Calculation = intCalculation
    End With
End Sub

Private Sub prcSort(lngUBound As Long, lngOBound As Long, varArray() As Variant)
    Dim lngIndex1 As Long, lngIndex2 As Long, varElement As Variant, varTemp As Variant
    lngIndex1 = lngUBound
    lngIndex2 = lngOBound
    varTemp = varArray(Fix((lngUBound + lngOBound) / 2))
    Do
        Do While varArray(lngIndex1) < varTemp
            lngIndex1 = lngIndex1 + 1
        Loop
        Do While varTemp < varArray(lngIndex2)
            lngIndex2 = lngIndex2 - 1
        Loop
        If lngIndex1 <= lngIndex2 Then
            varElement = varArray(lngIndex1)
            varArray(lngIndex1) = varArray(lngIndex2)
            varArray(lngIndex2) = varElement
            lngIndex1 = lngIndex1 + 1
            lngIndex2 = lngIndex2 - 1
        End If
    Loop Until lngIndex1 > lngIndex2
    If lngUBound < lngIndex2 Then Call prcSort(lngUBound, lngIndex2, varArray())
    If lngIndex1 < lngOBound Then Call prcSort(lngIndex1, lngOBound, varArray())
End Sub


Gruß
Nepumuk


Bild


Betrifft: AW: Liste automatisch sortieren nach Eintrag von: Udo
Geschrieben am: 19.02.2005 21:43:02

Hi,

ich glaube fast, das hast du falsch verstanden, oder ich?
Ich denke, dass die Spaltenstruktur beibehalten werden soll.
Mal sehen...

Gruß Udo


Bild


Betrifft: AW: Liste automatisch sortieren nach Eintrag von: Nepumuk
Geschrieben am: 20.02.2005 07:31:09

Morgen Udo,

das macht die Routine doch. Mit 60 Zeilen pro Spalte.

Hallo Silke,

eine leicht verbesserte Version:


Option Explicit
Option Compare Text

Public Sub prcDoIt()
    Dim bolExit As Boolean
    Dim intCalculation As Integer, intColumn As Integer, intCount As Integer
    Dim intIndex1 As Integer, intIndex2 As Integer
    Dim lngIndex As Long, lngRow As Long
    Dim varSortArray() As Variant, varArray() As Variant
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
        intCalculation = .Calculation
        .Calculation = -4135
    End With
    For intColumn = 256 To Step -2
        If Cells(Rows.Count, intColumn).End(-4162).Row >= 2 Then
            intCount = intCount + 1
            ReDim Preserve varArray(1 To intCount)
            varArray(intCount) = Range(Cells(2, intColumn), _
                Cells(Cells(Rows.Count, intColumn).End(-4162).Row, intColumn))
        End If
    Next
    For intIndex1 = 1 To intCount
        If VarType(varArray(intIndex1)) = 8204 Then
            For intIndex2 = 1 To UBound(varArray(intIndex1))
                If Trim(varArray(intIndex1)(intIndex2, 1)) <> "" Then
                    lngIndex = lngIndex + 1
                    ReDim Preserve varSortArray(1 To lngIndex)
                    varSortArray(lngIndex) = Trim(varArray(intIndex1)(intIndex2, 1))
                End If
            Next
        Else
            If Trim(varArray(intIndex1)) <> "" Then
                lngIndex = lngIndex + 1
                ReDim Preserve varSortArray(1 To lngIndex)
                varSortArray(lngIndex) = Trim(varArray(intIndex1))
            End If
        End If
    Next
    Call prcSort(1, lngIndex, varSortArray())
    Cells.Clear
    intIndex1 = 0
    For intColumn = 1 To 255 Step 2
        Cells(1, intColumn).Value = "Nr"
        Cells(1, intColumn + 1).Value = "Titel"
        If bolExit Then Exit For
        intIndex2 = 1
        Do Until intIndex1 = lngIndex Or intIndex2 = 61
            intIndex1 = intIndex1 + 1
            intIndex2 = intIndex2 + 1
            Cells(intIndex2, intColumn).Value = intIndex1
            Cells(intIndex2, intColumn + 1).Value = varSortArray(intIndex1)
        Loop
        If intIndex1 = lngIndex Then bolExit = True
    Next
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
        .Calculation = intCalculation
    End With
End Sub

Private Sub prcSort(lngUBound As Long, lngOBound As Long, varArray() As Variant)
    Dim lngIndex1 As Long, lngIndex2 As Long, varElement As Variant, varTemp As Variant
    lngIndex1 = lngUBound
    lngIndex2 = lngOBound
    varTemp = varArray(Fix((lngUBound + lngOBound) / 2))
    Do
        Do While varArray(lngIndex1) < varTemp
            lngIndex1 = lngIndex1 + 1
        Loop
        Do While varTemp < varArray(lngIndex2)
            lngIndex2 = lngIndex2 - 1
        Loop
        If lngIndex1 <= lngIndex2 Then
            varElement = varArray(lngIndex1)
            varArray(lngIndex1) = varArray(lngIndex2)
            varArray(lngIndex2) = varElement
            lngIndex1 = lngIndex1 + 1
            lngIndex2 = lngIndex2 - 1
        End If
    Loop Until lngIndex1 > lngIndex2
    If lngUBound < lngIndex2 Then Call prcSort(lngUBound, lngIndex2, varArray())
    If lngIndex1 < lngOBound Then Call prcSort(lngIndex1, lngOBound, varArray())
End Sub


Gruß
Nepumuk


Bild


Betrifft: Vielen Dank Nepumuk für die ganze Mühe o.T. von: Silke
Geschrieben am: 20.02.2005 09:18:55




 Bild

Beiträge aus den Excel-Beispielen zum Thema "Liste automatisch sortieren nach Eintrag"