wimgielis.com

Sorteren in een cel

• 13/04/2007

Inleiding

In Excel cellen sorteren is een koud kunstje. Selecteer eerst alle cellen van je bereik, ook meerdere kolommen kan je tegelijk sorteren. Als je slechts 1 kolom wil sorteren, druk dan op het A-Z icoontje of het Z-A icoontje in de Standaard werkbalk. Het is zo simpel als dat. Wil je (op) meerdere kolommen sorteren, kies dan voor Data > Sorteren. Duid de sorteervolgorde en de manier van sorteren (oplopend of aflopend) aan. En als je mijn Excel-tips al eens gelezen hebt, dan weet je ook dat sorteren op rijen ook kan.

Maar het wordt tricky als we de inhoud binnen 1 cel willen sorteren, alfabetisch. Je kan met name meerdere lijnen in 1 cel gebruiken door aan het einde van een lijn Alt + Enter te doen (linker Alt-toets dus op het klavier). Deze code is grotendeels overgenomen uit mijn antwoord op deze vraag op Helpmij. Zo ziet het er uit met een dom voorbeeldje:

VBA-code

Sub SorterenInEenCel()
' Wim Gielis
' https://www.wimgielis.com
'''''
' Module to sort multiple lines in one cell alphabetically
' 13/04/07
'''''
Dim l As Long
Dim arrSubParts As Variant
Dim rngSort As Range
Dim rng As Range
Dim strToSort As String
Dim str1 As String, str2 As String
Dim lLoop As Long, lLoop2 As Long

Set rngSort = Application.InputBox("Duid de te sorteren cellen aan.", "Cellenbereik", Selection.Address, Type:=8)
If rngSort Is Nothing Then Exit Sub

Application.ScreenUpdating = False

For Each rng In rngSort
    strToSort = rng.Value
    If strToSort <> "" Then

        Do While InStr(strToSort, Chr(10) & Chr(10)) > 0
            strToSort = Replace(strToSort, Chr(10) & Chr(10), Chr(10))
        Loop
        Do While Left(strToSort, 1) = Chr(10)
            strToSort = Right(strToSort, Len(strToSort) - 1)
        Loop
        Do While Right(strToSort, 1) = Chr(10)
            strToSort = Left(strToSort, Len(strToSort) - 1)
        Loop

        arrSubParts = Split(strToSort, Chr(10))

        For lLoop = 0 To UBound(arrSubParts)
            For lLoop2 = lLoop To UBound(arrSubParts)
                If UCase(arrSubParts(lLoop2)) < UCase(arrSubParts(lLoop)) Then
                    str1 = arrSubParts(lLoop)
                    str2 = arrSubParts(lLoop2)
                    arrSubParts(lLoop) = str2
                    arrSubParts(lLoop2) = str1
                End If
            Next lLoop2
        Next lLoop

        rng.Value = Join(arrSubParts, Chr(10))
    End If
Next rng

Application.ScreenUpdating = True

End Sub

Ook deze code is vanuit didactisch oogpunt enorm interessant voor zij die VBA onder de knie willen krijgen. Bekijk op een druilerige zaterdagnamiddag zeker eens in detail de code hierboven. Veel plezier met de code.

• « Vorig Excel artikel
• Volgend Excel artikel »