How to sort string of numbers with multiple decimal places in VBA

Question

I currently have an Excel spreadsheet with over 2000 rows of data. In one of the columns, i have an ID that is a string containing multiple decimal points. I need to sort the data in my Excel spreadsheet based off this ID. The column of ID's look like:

1.01.1.3.1
1.01.1.5.2
1.01.1.3.13
1.01.1.3.2
1.02.5.1.1.1.1
1.01.1.3.1.1
1.01.1.3.2.1

And the result needs to look like:

1.01.1.3.1
1.01.1.3.1.1
1.01.1.3.2
1.01.1.3.2.1
1.01.1.3.13
1.01.1.5.2
1.02.5.1.1.1.1

I am using VBA to pull the data from the spreadsheet and store in an array, but i am unsure how to approach sorting the string from left to right. I know i have to Split each entry by "." and sort the first index then the next index but i fear this method would take too long over the 2000+ entries. Im also unsure how to handle entries that have 5 indexes (Ex: 1.01.1.1.1) compared to an entry with 9 indexes (Ex: 1.01.1.1.2.5.1.1.1)

Another issue is that some entries contain letters. Ex: 1.01.1.4.1A

Note, I have this BubbleSort function:

Public Function BubbleSort(ByVal tempArray As Variant) As Variant
Dim Temp As Variant
Dim i As Integer
Dim NoExchanges As Integer

    ' Loop until no more "exchanges" are made.
    Do
        NoExchanges = True

        ' Loop through each element in the array.
        For i = 0 To UBound(tempArray) - 1

            ' Substitution when element is greater than the element following int
            If tempArray(i) > tempArray(i + 1) Then
                NoExchanges = False
                Temp = tempArray(i)
                tempArray(i) = tempArray(i + 1)
                tempArray(i + 1) = Temp
            End If

        Next i

    Loop While Not (NoExchanges)

    BubbleSort = tempArray

End Function

If anyone has any insight for a solution, your help is kindly appreciated.

Answer 1

I grabbed the following from my vault of Sorting routines. Please ignore some of my naming conventions :).

Upon review, I noticed an issue with my CompareNaturalNum() routine where it considered "1.01.1.3.1" and "1.01.1.3.1.1" the same. I've fixed it in the following code, and shown how to use it.

QuickSortMultiNaturalNum - A Quick sort for variant arrays, where you specify the column to be sorted.

Public Sub QuickSortMultiNaturalNum(strArray As Variant, intBottom As Long, intTop As Long, intSortIndex As Long, Optional intLowIndex As Long, Optional intHighIndex As Long = -1)
Dim strPivot As String, strTemp As String
Dim intBottomTemp As Long, intTopTemp As Long
Dim i As Long

intBottomTemp = intBottom
intTopTemp = intTop

If intHighIndex < intLowIndex Then
    If (intBottomTemp <= intTopTemp) Then
        intLowIndex = LBound(strArray, 2)
        intHighIndex = UBound(strArray, 2)
    End If
End If

strPivot = strArray((intBottom + intTop) \ 2, intSortIndex)

While (intBottomTemp <= intTopTemp)

' < comparison of the values is a descending sort
While (CompareNaturalNum(strArray(intBottomTemp, intSortIndex), strPivot) < 0 And intBottomTemp < intTop)
    intBottomTemp = intBottomTemp + 1
Wend

While (CompareNaturalNum(strPivot, strArray(intTopTemp, intSortIndex)) < 0 And intTopTemp > intBottom)
    intTopTemp = intTopTemp - 1
Wend

If intBottomTemp < intTopTemp Then
    For i = intLowIndex To intHighIndex
        strTemp = Var2Str(strArray(intBottomTemp, i))
        strArray(intBottomTemp, i) = Var2Str(strArray(intTopTemp, i))
        strArray(intTopTemp, i) = strTemp
    Next
End If

If intBottomTemp <= intTopTemp Then
    intBottomTemp = intBottomTemp + 1
    intTopTemp = intTopTemp - 1
End If

Wend

'the function calls itself until everything is in good order
If (intBottom < intTopTemp) Then QuickSortMultiNaturalNum strArray, intBottom, intTopTemp, intSortIndex, intLowIndex, intHighIndex
If (intBottomTemp < intTop) Then QuickSortMultiNaturalNum strArray, intBottomTemp, intTop, intSortIndex, intLowIndex, intHighIndex
End Sub

CompareNaturalNum - Custom Compare function

Function CompareNaturalNum(string1 As Variant, string2 As Variant) As Long
'string1 is less than string2 -1
'string1 is equal to string2 0
'string1 is greater than string2 1
Dim n1 As Long, n2 As Long
Dim iPosOrig1 As Long, iPosOrig2 As Long
Dim iPos1 As Long, iPos2 As Long
Dim nOffset1 As Long, nOffset2 As Long

    If Not (IsNull(string1) Or IsNull(string2)) Then
        iPos1 = 1
        iPos2 = 1
        Do While iPos1 <= Len(string1)
            If iPos2 > Len(string2) Then
                CompareNaturalNum = 1
                Exit Function
            End If
            If isDigit(string1, iPos1) Then
                If Not isDigit(string2, iPos2) Then
                    CompareNaturalNum = -1
                    Exit Function
                End If
                iPosOrig1 = iPos1
                iPosOrig2 = iPos2
                Do While isDigit(string1, iPos1)
                    iPos1 = iPos1 + 1
                Loop

                Do While isDigit(string2, iPos2)
                    iPos2 = iPos2 + 1
                Loop

                nOffset1 = (iPos1 - iPosOrig1)
                nOffset2 = (iPos2 - iPosOrig2)

                n1 = Val(Mid(string1, iPosOrig1, nOffset1))
                n2 = Val(Mid(string2, iPosOrig2, nOffset2))

                If (n1 < n2) Then
                    CompareNaturalNum = -1
                    Exit Function
                ElseIf (n1 > n2) Then
                    CompareNaturalNum = 1
                    Exit Function
                End If

                ' front padded zeros (put 01 before 1)
                If (n1 = n2) Then
                    If (nOffset1 > nOffset2) Then
                        CompareNaturalNum = -1
                        Exit Function
                    ElseIf (nOffset1 < nOffset2) Then
                        CompareNaturalNum = 1
                        Exit Function
                    End If
                End If
            ElseIf isDigit(string2, iPos2) Then
                CompareNaturalNum = 1
                Exit Function
            Else
                If (Mid(string1, iPos1, 1) < Mid(string2, iPos2, 1)) Then
                    CompareNaturalNum = -1
                    Exit Function
                ElseIf (Mid(string1, iPos1, 1) > Mid(string2, iPos2, 1)) Then
                    CompareNaturalNum = 1
                    Exit Function
                End If
                iPos1 = iPos1 + 1
                iPos2 = iPos2 + 1
            End If
        Loop
        ' Everything was the same so far, check if Len(string2) > Len(String1)
        ' If so, then string1 < string2
        If Len(string2) > Len(string1) Then
            CompareNaturalNum = -1
            Exit Function
        End If
    Else
        If IsNull(string1) And Not IsNull(string2) Then
            CompareNaturalNum = -1
            Exit Function
        ElseIf IsNull(string1) And IsNull(string2) Then
            CompareNaturalNum = 0
            Exit Function
        ElseIf Not IsNull(string1) And IsNull(string2) Then
            CompareNaturalNum = 1
            Exit Function
        End If
    End If
End Function

isDigit - Simple function to let you know if the string value is a digit (0-9)

Function isDigit(ByVal str As String, pos As Long) As Boolean
Dim iCode As Long
    If pos <= Len(str) Then
        iCode = Asc(Mid(str, pos, 1))
        If iCode >= 48 And iCode <= 57 Then isDigit = True
    End If
End Function

Var2Str - Since it deals with Variants, the values could be Null, so convert it to a string

Public Function Var2Str(Value As Variant, Optional TrimSpaces As Boolean = True) As String
    If IsNull(Value) Then
        'Var2Str = vbNullString
        Exit Function
    End If
    If TrimSpaces Then
        Var2Str = Trim(Value)
    Else
        Var2Str = CStr(Value)
    End If
End Function

Test - Here is sample code of how to use it. Just change the Range values. The last 1 in the call to QuickSortMultiNaturalNum is the column to be sorted (the column the ID's are in).

Sub Test()
Dim Target As Range
Dim vData 'as Variant
Dim Rows As Long
    ' Set Target to the CurrentRegion of cells around "A1"
    Set Target = Range("A1").CurrentRegion
    ' Copy the values to a variant
    vData = Target.Value2
    ' Get the high/upper limit of the array
    Rows = Target.Rows.Count    'UBound(vData, 1)
    ' Sor The variant array, passing the variant, lower limit, upper limit and the index of the column to be sorted.
    QuickSortMultiNaturalNum vData, 1, Rows, 1
    ' Paste the values back onto the sheet.  For testing, you may want to paste it to another sheet/range
    Range("A1").Resize(Target.Rows.Count, Target.Columns.Count).Value = vData
End Sub

Answer 2

If you are allowed to use additional columns do the following:

• Copy the ID column to a new column
• Check the maximum number of dots in every cell
• Remove each non-numeric [^0-9] and non-dot [^.] from every cell
• Amend each cell, including the maximal number of dots like this:

From:

1.01.1.3.13

To:

1.01.01.03.13.00

• E.g. adding a zero, if it is consisting only of 1 value and adding additional points, to equalize to the maximal value with points.

• In the new column remove the dots

• Sort by the new column
• Delete the new column
• This is it!

If you are not allowed to use additional columns, then you should use some mapping techniques.

Answer 3

This code splits the range using the . delimiter.
It then adds a 0 to the blank cells in the split before sorting based on the split, but also including the original text.
The split cells are then cleared leaving just the sorted original values.
1.01.1.4.1A appears between 1.01.1.3.13 and 1.01.1.5.2.

Sub Test()

    Dim wrkSht As Worksheet
    Dim rng As Range
    Dim rng_Split As Range
    'Dim rng_Blanks As Range - EDIT: Not needed.
    Dim lLastCol As Long
    Dim rCol As Range

    Set wrkSht = ThisWorkbook.Worksheets("Sheet1")

    'Split the value and find the last column it splits to.
    With wrkSht
        'Adjust the range to yours.
        Set rng = .Range("A31:A38")

        rng.TextToColumns _
            Destination:=rng.Offset(, 1), _
            DataType:=xlDelimited, _
            Other:=True, _
            OtherChar:="."

        lLastCol = rng.EntireRow.Cells.Find("*", , , , xlByColumns, xlPrevious).Column
    End With

    'Add a 0 to all blank cells.
    Set rng_Split = rng.Offset(, 1).Resize(rng.Rows.Count, lLastCol - 1)
    rng_Split.SpecialCells(xlCellTypeBlanks).Value = 0

    With wrkSht
        With .Sort
            .SortFields.Clear
            For Each rCol In rng_Split.Columns
                .SortFields.Add Key:=rCol, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            Next rCol
            'Adjust this range to include all columns to be sorted.
            .SetRange rng_Split.Offset(, -1).Resize(, lLastCol)
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .Apply
        End With
    End With

    rng_Split.ClearContents

End Sub

Edit: Using this method 01 and 1 are considered the same.