Custom sorting in VBA (possibly from a list)

Question

Table to sort:

I have a 2000-ish entry table. The first column contains an ID (non-unique) of the following type: [numeric 1-52][letters][optional underscore][optional numeric 1-10]. Letters will be either [a], [b], [c], [sa], [sb], [sc].

Example: 1c, 10sb_3, 5a, 12c, 3sc, 21c_1, 22c_4, 22b_10, 14sb, 26sb.

How I want the sorting done

I want to sort by type (letter) first, in the order I named them before the example above. In case of same type, I want to sort by the first number. In case of same first number (both optional parameters will be present) I want to sort by the last number. The sorting should extend to the rest of the row (table) as well.

Desired end result

1c
1c
1c
2c
3c
3c
4c_1
4c_2
4c_3
5c
6c_1
.......
1b
2b
2b
3b
4b_1
4b_2
5b
5b
.......
etc

What I intended to do (may not be the best idea)

Using the answer of this question as a starting point: Code an Excel VBA sort with a custom order and a value containing commas

I could make an algorithm which creates a second list, on the side, removing all duplicates, and order that list how I want manually. It would take a while, and is possibly incredibly inefficient. When it is done, I would use a piece of code similar to the answer's:

Dim oWorksheet As Worksheet
Set oWorksheet = ActiveWorkbook.Worksheets("Sheet1")
Dim oRangeSort As Range
Dim oRangeKey As Range

' one range that includes all colums do sort
Set oRangeSort = oWorksheet.Range("A1:J2000") ' <<<<I'd set the range right, of course
' start of column with keys to sort
Set oRangeKey = oWorksheet.Range("B1") '<<<What is this for?

' custom sort order
Dim sCustomList(x To y) As String
'There would be a loop here filling the array in order with my manually sorted list

Application.AddCustomList ListArray:=sCustomList
' use this if you want a list on the spreadsheet to sort by
' Application.AddCustomList ListArray:=Range("D1:D3")
' ^^^^ for the record I'm not sure what this accomplishes in my case. Should I remove it? I feel it is just a different way to fill the array, using the range directly instead of filling with a loop. Maybe it suits me more?

oWorksheet.Sort.SortFields.Clear
oRangeSort.Sort Key1:=oRangeKey, Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=Application.CustomListCount + 1, MatchCase:=False, _
    Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

' clean up
Application.DeleteCustomList Application.CustomListCount
Set oWorksheet = Nothing

Answer 1

Personally, unless you need to do this as part of a larger piece of code, I wouldn't use VBA and would just do this by adding a column to your data sheet that gives you the correct sort order.

To extract the relevant pieces of your ID (assuming it starts in cell "A1") you need to pull out the letters from your string:

=MID(A1,MIN(FIND({"a","b","c","s"},A1&"abcs")),IF(ISNUMBER(FIND("s",A1)),2,1))

Next you need the first number:

=LEFT(A1,MIN(FIND({"a","b","c","s"},A1&"abcs"))-1)

Then you need to add on the second number if it exists:

=IF(ISNUMBER(FIND("_",A1)),RIGHT(A1,LEN(A1)-FIND("_",A1))*1,0)

Putting these all into a single formula and formatting the numbers to take account of single or double-digit numbers gives:

=MID(A1,MIN(FIND({"a","b","c","s"},A1&"abcs")),IF(ISNUMBER(FIND("s",A1)),2,1))&TEXT(LEFT(A1,MIN(FIND({"a","b","c","s"},A1&"abcs"))-1),"00")&TEXT(IF(ISNUMBER(FIND("_",A1)),RIGHT(A1,LEN(A1)-FIND("_",A1))*1,0),"00")

Which is probably not the simplest way of achieving it, but will give you a column of strings which you can use as your sort order.

The only thing I am confused about is that your question said that the letters needed to be sorted in the order that you listed them, but your example showed "c" coming before "b". If you need the letters to be in non-alphabetical order, we would need to adjust the first part of this formula.

Answer 2

If possible, to make it easier, the first thing I'd suggest is to keep the fields (type, first number, special parameter, optional numeric) all the same lenght, that would make the algorithm incredibly easier.

• 1c2 becomes 01oc-02
• 23sa_13 keeps 23sa_13

But if you don't have that possibility, here it goes:

This separates all values in a new sheet, one by one, including repeated

Option Explicit

Sub SortData()


    Dim MySheet As Worksheet, NewSheet As Worksheet
    Set MySheet = ThisWorkbook.Worksheets("Sheet1")
    Set NewSheet = ThisWorkbook.Worksheets.Add()

    NewSheet.Range("A1").value = "Type"
    NewSheet.Range("B1").value = "First Number"
    NewSheet.Range("C1").value = "Underscore"
    NewSheet.Range("D1").value = "Last Number"

    Dim CurrentRange As Range
    Dim i As Integer

    For i = 2 To 2000 'the rows you are going to consider
        'you may replace this for a while cell is not empty check
        'considering the first row is a header, not a value

        Set CurrentRange = MySheet.Cells(i, 1)  'gets the cell in row i and column 1
        Dim CurrentValue As String
        CurrentValue = CurrentRange.value   'gets the value of the cell

        'if cell is empty, stop loop
        If CurrentValue = "" Then
            Exit For
        End If

        Dim FirstNumberSize As Integer
        Dim TypeSize As Integer
        Dim UnderscoreSize As Integer
        Dim LastNumberSize As Integer

        Dim StartChar As Integer
        StartChar = 1
        Call GetFieldSizes(CurrentValue, FirstNumberSize, TypeSize, UnderscoreSize, LastNumberSize)


        'write the values in a new sheet
        NewSheet.Cells(i, 2).value = Mid(CurrentValue, StartChar, FirstNumberSize) 'write firstnumber in the new sheet
        StartChar = StartChar + FirstNumberSize 'advance to the next field

        NewSheet.Cells(i, 1).value = Mid(CurrentValue, StartChar, TypeSize) 'write type in the new sheet
        StartChar = StartChar + TypeSize

        NewSheet.Cells(i, 3).value = Mid(CurrentValue, StartChar, UnderscoreSize) 'write underscore in the new sheet - nothing if size is zero
        StartChar = StartChar + UnderscoreSize

        NewSheet.Cells(i, 4).value = Mid(CurrentValue, StartChar, LastNumberSize) 'write lastNumber in the new sheet - nothing if size is zero
    Next

End Sub

Sub GetFieldSizes(value As String, ByRef firstNum As Integer, ByRef entryType As Integer, ByRef Underscore As Integer, ByRef lastNum As Integer)

    'walk through each char of the value while it's a number


    Dim Continue As Boolean
    Dim charVal As String
    Dim valLength As Integer
    valLength = Len(value) 'the length of the string


    'find first number size
    firstNum = 0  'start from character zero
    Continue = True 'to check if I can advance to the next char
    Do
        'if the next char is not a number, we found the letters
        If Not IsNumeric(Mid(value, firstNum + 1, 1)) Then
            Continue = False    'I say I cannot advance anymore, the size of our number is found
        Else
            firstNum = firstNum + 1 'advance one char
        End If

    Loop While Continue = True 'repeat while I can continue


    'find first underscore or digit of last number

    For Underscore = firstNum + 1 To valLength 'from the first char after the first number to the end of the string

        charVal = Mid(value, Underscore, 1) 'get the value of the char in the current underscore position

        If charVal = "_" Then   'if the char is an underscore
            lastNum = valLength - Underscore 'the remaining chars are the last number
            Underscore = 1 'the actual size of the underscore is 1
            Exit For 'interrupt the loop
        ElseIf IsNumeric(charVal) Then  'if the char is a number
            lastNum = valLength - Underscore + 1 'the remaining chars, including this one are the last number
            Underscore = 0 'if I find a number instead of the underscore, it doesn't exist, say it's length is zero
            Exit For 'interrupt the loop
        End If
    Next

    'if I advanced to the end of the string, I didn't find any number of underscore
    If Underscore > valLength Then
        lastNum = 0
        Underscore = 0
    End If

    entryType = valLength - firstNum - Underscore - lastNum 'the size of the letters is the remaining size when you remove the other sizes
End Sub