Sorting individual Cells

Hi,

This code might help. See the link below and look under VBA - For Beginners if your not sure how to add the code

Sub SortInOneCell()
    Dim RawCellData As String
    Dim ToBeSorted() As String
    Dim TheSeparator As String
    Dim IsSorted As Boolean
    Dim BubbleLoop As Integer
    Dim SwapHolder As String


    If IsEmpty(Selection) Then
        MsgBox "Empty Cell"
        Exit Sub ' no work to be done
    End If


    ReDim ToBeSorted(1) 'initialize
    TheSeparator = " " ' change if something besides space
    RawCellData = Selection.Value
    'force space at end of string if one isn't there
    'when we start here
    If Right(RawCellData, 1) <> TheSeparator Then
        RawCellData = RawCellData & TheSeparator
    End If


    Do Until InStr(RawCellData, TheSeparator) = 0
        ToBeSorted(UBound(ToBeSorted)) = _
        Left(RawCellData, InStr(RawCellData, TheSeparator) - 1)
        If Len(RawCellData) = Len(ToBeSorted(UBound(ToBeSorted))) + 1 Then
            RawCellData = "" ' all done
        Else ' more work to be done
            'remove what we just put into the array
            RawCellData = _
            Right(RawCellData, Len(RawCellData) - _
            (Len(ToBeSorted(UBound(ToBeSorted))) + 1))
        End If
        'make room for another - will end up being empty
        ReDim Preserve ToBeSorted(UBound(ToBeSorted) + 1)
    Loop
    'now a simple bubble kind of sort to get them in ascending order
    Do Until IsSorted = True
        IsSorted = True ' not really, but may be later
        For BubbleLoop = LBound(ToBeSorted) To UBound(ToBeSorted) - 1
            If ToBeSorted(BubbleLoop + 1) < ToBeSorted(BubbleLoop) Then
                SwapHolder = ToBeSorted(BubbleLoop)
                ToBeSorted(BubbleLoop) = ToBeSorted(BubbleLoop + 1)
                ToBeSorted(BubbleLoop + 1) = SwapHolder
                IsSorted = False ' wasn't this time thru
            End If
        Next
    Loop
    'now rebuild the string
    'reuse BubbleLoop counter and RawCellData for this loop also
    RawCellData = "" ' just to make sure it's empty
    For BubbleLoop = LBound(ToBeSorted) To UBound(ToBeSorted)
        If ToBeSorted(BubbleLoop) <> "" Then
            RawCellData = RawCellData & ToBeSorted(BubbleLoop) & TheSeparator
        End If
    Next
    Selection.Value = Trim(RawCellData)
End Sub

VBA Noob

Hi,

Try this. It assumes data to sort starts in A10. Change as required

Sub Marco()
Dim lLastRow As Long
Dim x As Integer
Dim i As Integer
Dim Cell As Range
lLastRow = Range("A10").End(xlDown).Row ' Change to your start cell
     
    Set Cell = Range("A10:A" & lLastRow) ' Change to your start cell

    x = Cell.Count
    For i = 0 To x - 1
    Range("A10").Activate ' Change to your start cell
    ActiveCell.Offset(i, 0).Activate
    Call SortInOneCell
    Next i
End Sub

Sub SortInOneCell()
    Dim RawCellData As String
    Dim ToBeSorted() As String
    Dim TheSeparator As String
    Dim IsSorted As Boolean
    Dim BubbleLoop As Integer
    Dim SwapHolder As String
   
    On Error Resume Next
    If IsEmpty(Selection) Then
        MsgBox "Empty Cell"
        Exit Sub ' no work to be done
    End If


    ReDim ToBeSorted(1) 'initialize
    TheSeparator = " " ' change if something besides space
   RawCellData = Selection.Value
    'force space at end of string if one isn't there
    'when we start here
    If Right(RawCellData, 1) <> TheSeparator Then
        RawCellData = RawCellData & TheSeparator
    End If


    Do Until InStr(RawCellData, TheSeparator) = 0
        ToBeSorted(UBound(ToBeSorted)) = _
        Left(RawCellData, InStr(RawCellData, TheSeparator) - 1)
        If Len(RawCellData) = Len(ToBeSorted(UBound(ToBeSorted))) + 1 Then
            RawCellData = "" ' all done
        Else ' more work to be done
            'remove what we just put into the array
            RawCellData = _
            Right(RawCellData, Len(RawCellData) - _
            (Len(ToBeSorted(UBound(ToBeSorted))) + 1))
        End If
        'make room for another - will end up being empty
        ReDim Preserve ToBeSorted(UBound(ToBeSorted) + 1)
    Loop
    'now a simple bubble kind of sort to get them in ascending order
    Do Until IsSorted = True
        IsSorted = True ' not really, but may be later
        For BubbleLoop = LBound(ToBeSorted) To UBound(ToBeSorted) - 1
            If ToBeSorted(BubbleLoop + 1) < ToBeSorted(BubbleLoop) Then
                SwapHolder = ToBeSorted(BubbleLoop)
                ToBeSorted(BubbleLoop) = ToBeSorted(BubbleLoop + 1)
                ToBeSorted(BubbleLoop + 1) = SwapHolder
                IsSorted = False ' wasn't this time thru
            End If
        Next
    Loop
    'now rebuild the string
    'reuse BubbleLoop counter and RawCellData for this loop also
    RawCellData = "" ' just to make sure it's empty
    For BubbleLoop = LBound(ToBeSorted) To UBound(ToBeSorted)
        If ToBeSorted(BubbleLoop) <> "" Then
            RawCellData = RawCellData & ToBeSorted(BubbleLoop) & TheSeparator
        End If
    Next
    Selection.Value = Trim(RawCellData)
End Sub

VBA Noob

No problem

I'm sure the code to call the SortInOneCell could be more dynamic but still learning myself so I'm using you as a guinea pig

VBA Noob