Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
572to576
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
572to576
572to576
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Liste automatisch sortieren nach Eintrag

Liste automatisch sortieren nach Eintrag
19.02.2005 19:24:03
Silke
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

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Liste automatisch sortieren nach Eintrag
Udo
Ganz schöner Aufwand, lad mal eine Mustertabelle hoch.
Udo
AW: Liste automatisch sortieren nach Eintrag
19.02.2005 19:42:19
Silke
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
AW: Liste automatisch sortieren nach Eintrag
19.02.2005 21:07:34
Nepumuk
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
Anzeige
AW: Liste automatisch sortieren nach Eintrag
Udo
Hi,
ich glaube fast, das hast du falsch verstanden, oder ich?
Ich denke, dass die Spaltenstruktur beibehalten werden soll.
Mal sehen...
Gruß Udo
AW: Liste automatisch sortieren nach Eintrag
20.02.2005 07:31:09
Nepumuk
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
Anzeige
Vielen Dank Nepumuk für die ganze Mühe o.T.
20.02.2005 09:18:55
Silke

302 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige