Einträge in mehreren Zellen mit VBA alphabetisch sortieren

[tokashio1]

Hallo zusammen,

ich würde gerne um Eure Hilfe bitten. Ich habe eine Spalte mit mehreren hundert Zellen. Innerhalb der Zellen finden sich verschiedene Begrifflichkeiten, sie sind mit einem Komma und einem Leerzeichen voneinander getrennt. Die Anzahl der Begriffe pro Zelle unterscheidet sich. 
Ich würde gerne die Begriffe in den Zellen alphabetisch sortieren. Da ich mich mit VBA überhaupt nicht auskenne habe ich lange in Foren recherchiert, konnte allerdings keine Lösung finden, die bei mir funktioniert hat. 
Einzig und alleine dieser Code, s.u., ebenfalls aus einem Forum, ging in die richtige Richtung. (Link zum Original)
Allerdings lässt er sich nur auf eine vorab definierte Zelle anwenden, nicht aber auf alle Zellen innerhalb einer Spalte. Bei dem Umfang meiner Tabelle wäre es eine sehr langfristige Aufgabe jede einzelne Zelle manuell anzusteuern. 

Hat denn jemand vielleicht eine Lösung für das Problem? Gibt es irgendwo eine funktionales Skript, welches ich bei meiner Recherche übersehen habe?  Für Hilfe wäre ich sehr dankbar!

Code:

Option Explicit
Option Compare Text

Sub sortieren_zelle()
   Dim arrTmp, x As Long
   With Range("A23")
       arrTmp = Split(.Value, ",")
       For x = 0 To UBound(arrTmp)
           arrTmp(x) = Trim(arrTmp(x))
       Next
       QuickSort arrTmp
       .Value = Join(arrTmp, ", ")
   End With
End Sub

Sub QuickSort(ByRef DasArray, Optional ErsteZeile = -1, Optional LetzteZeile = -1)
   Dim UnterGrenze As Long, OberGrenze As Long
   Dim AktuellerWert, GemerkterWert As Variant, tmpWert As Variant
   
   If ErsteZeile < 0 Then ErsteZeile = LBound(DasArray)
   If LetzteZeile < 0 Then LetzteZeile = UBound(DasArray)
   
   UnterGrenze = ErsteZeile
   OberGrenze = LetzteZeile
   AktuellerWert = DasArray((ErsteZeile + LetzteZeile) \ 2)
   
   Do While (UnterGrenze <= OberGrenze)
       Do While (DasArray(UnterGrenze) < AktuellerWert And UnterGrenze < LetzteZeile)
           UnterGrenze = UnterGrenze + 1
       Loop
       Do While (DasArray(OberGrenze) > AktuellerWert And OberGrenze > ErsteZeile)
           OberGrenze = OberGrenze - 1
       Loop
       
       If (UnterGrenze <= OberGrenze) Then
           GemerkterWert = DasArray(UnterGrenze)
           DasArray(UnterGrenze) = DasArray(OberGrenze)
           DasArray(OberGrenze) = GemerkterWert
           UnterGrenze = UnterGrenze + 1
           OberGrenze = OberGrenze - 1
       End If
   Loop
   
   If (OberGrenze > ErsteZeile) Then Call QuickSort(DasArray, ErsteZeile, OberGrenze)
   If (UnterGrenze < LetzteZeile) Then Call QuickSort(DasArray, UnterGrenze, LetzteZeile)
End Sub

[Fennek]

Hallo,

VBA ist für Sortieren nicht gut ausgelegt, aber "bubble-sort" muss es dann doch nicht sein.

Es ist einfacher in einem freien Bereich des Sheets zu sortieren:

siehe Datei.

mfg

(falls es nicht geht, einfach den Bereich Spalte E einmal per Menü sortieren)

[tokashio1]

Hi,

danke für die Info, Erklärung und Datei. Ich denke mit diesem Weg werde ich mich mal intensiver auseinandersetzen. 
LG

[tokashio1]

Hi Fennek,

habe mir die Datei jetzt mal angesehen. So ganz schlau werde ich aber nicht daraus. Werte in einer einzelnen Zelle sortieren kann ich schon. Ich habe dies, wie in deiner Beispieldatei, über Hilfspalten gelöst. 
Mir ist aber nicht klar, wie ich zahlreiche Zellen automatisch sortiere, so dass die Einträge in jeder Zelle alphabetisch geordnet werden. Übersehe ich etwas? 
Kannst Du mir hierzu noch einen Tipp geben?

LG

[Fennek]

Annahmen:

- Werte in Spalte A
- Spalte B - F sind leer
falls nicht, muss die Ausgabe (in Spalte B) und der Sortierbereich (Spalte E) angepasst werden

Code:

Sub F_en()
Dim rng As Range
for i = 1 to cells(i,1).end(xlup).row
    Tx = Split(Cells(i, 1), ", ")
    Cells(1, 5).Resize(UBound(Tx) + 1) = Application.Transpose(Tx)
    Set rng = Cells(1, 5).CurrentRegion

    With rng
            .Sort rng.Cells(1), xlAscending, , , , , , xlNo
    End With

    Cells(i, 2) = Join(Application.Transpose(rng), ", ")
    rng.clear
next i
End Sub

(ungeprüft)

[tokashio1]

Funktioniert leider nicht. Bin gerade am Versuch das ganze nachzuvollziehen, da ich mich damit aber gar nicht auskenne, bin ich leider noch nicht auf dem Weg zum Erfolg. Mal sehen...

[Fennek]

Code:

Sub F_en()
Dim rng As Range
for i = 1 to cells(rows.count,1).end(xlup).row
    Tx = Split(Cells(i, 1), ", ")
    Cells(1, 5).Resize(UBound(Tx) + 1) = Application.Transpose(Tx)
    Set rng = Cells(1, 5).CurrentRegion

    With rng
            .Sort rng.Cells(1), xlAscending, , , , , , xlNo
    End With

    Cells(i, 2) = Join(Application.Transpose(rng), ", ")
    rng.clear
next i
End Sub

(mit LO getestet)

[Elex]

Hi

Alternativ.

Kein Hilfs-Zellbereich nötig.

Code:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim ArrListe As Object, j As Long, jj As Long, Werte, Werte2

Set ArrListe = CreateObject("System.Collections.ArrayList")
Werte = Range("C3:C9").Value2   'Hier stehen die Daten z.B. C3:C9

For j = 1 To UBound(Werte, 1)
   Werte2 = Split(Werte(j, 1), ", ")
     For jj = 0 To UBound(Werte2, 1)
        ArrListe.Add (Werte2(jj))
     Next jj
   ArrListe.Sort
   Werte(j, 1) = Join(ArrListe.toarray, ", ")
   ArrListe.Clear
Next j

'Hier werden die Daten Ausgegeben kann auch C3:C9 sein. Dann wird überschrieben
Range("D3:D9").Value2 = Werte
Cancel = True
End Sub

Gruß Elex

[tokashio1]

Hi Elex,

super, vielen Dank! Das werde ich auch heute testen. Mit dem anderen Skript hatte ich noch meine Probleme. Da ich nur wenig Erfahrung mit Skripten habe dauert es ziemlich lange bis ich mich eingelesen habe und da etwas klarer durchsteige. Klasse, dass Ihr mich beide unterstützt!

LG

[tokashio1]

Hey, gerade mal getestet. Funktioniert! Das ist fantastisch!  :18:
Jetzt muss ich mich nur mal damit auseinandersetzen, wie das Skript eigentlich funktioniert. Man will ja auch was lernen.
Vielen Dank noch mal!

LG