Sorting based on letter, and then on number

Hi all,

I have a column of values with each row in that column composed of 1 to 3 letters, and then a number, with the length of this number ranging from 1 to 5 digits.

The letters all belong in a group, (e.g. AA, B, C, CB, J, T) and so need to be grouped together when sorting, and the numbers then are to increase sequentially.

Below is a table with my intended input and desired output.

Input	Output
AA1	AA1
T4	B5
T1	C27
B5	CB5
J23	CB12
J19	J19
C27	J23
CB12	T1
CB5	T4

Is this something that can be achieved with VBA?

If so, any guidance would be greatly appreciated :)

Cheers,
enjam

Use This Code if it is help full to you or not

Code:

---


Sub Sorting()
Dim InSheet As Worksheet
    Set InSheet = ThisWorkbook.Worksheets("Sheet1")
    Dim LastRow As Integer
        LastRow = InSheet.Cells(Rows.Count, "A").End(xlUp).Row


With InSheet.Sort  ' sort data from A to Z
    .SetRange InSheet.Range("A1:A9" & LastRow)
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
End Sub

---

Thanks for your reply Prasadk, unfortunately the code does not achieve the desired output

This seems to match what you wanted

You might have to change the way the logic is used since I used a driver sub and the range to sort is hard coded

It basically takes the cells in the sort range, reformats in a format to sort, sorts, and then changes the cell back to the original format

Code:

---

Option Explicit


Sub drv()
   
    Call LetterNumberSort(Range("A2:A10"))


End Sub




' composed of 1 to 3 letters, and then a number, with the length of this number ranging from 1 to 5 digits.
Sub LetterNumberSort(r As Range)
    Dim c As Range
    Dim i As Long
    Dim s As String
   
    With r
   
        For Each c In .Cells
            c.Value = pvtFormatToSort(c.Value)
        Next




        With .Parent.Sort
            .SortFields.Clear
            .SortFields.Add Key:=r, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange r
            .Header = xlNo
            .MatchCase = True
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
       
        For Each c In .Cells
            c.Value = pvtFormatToDisplay(c.Value)
        Next
    End With
End Sub




Private Function pvtFormatToSort(s As String) As String
    Dim s1 As String, s2 As String, s3 As String
   
    s1 = Trim(UCase(s))
   
    If s1 Like "[A-Za-z]#*" Then
        s2 = Left(s1, 1) & "00"
        s3 = Right("00000" & Right(s1, Len(s1) - 1), 5)
       
    ElseIf s1 Like "[A-Za-z][A-Za-z]#*" Then
        s2 = Left(s1, 2) & "0"
        s3 = Right("00000" & Right(s1, Len(s1) - 2), 5)
       
   
    ElseIf s1 Like "[A-Za-z][A-Za-z][A-Za-z]#*" Then
        s2 = Left(s1, 3)
        s3 = Right("00000" & Right(s1, Len(s1) - 3), 5)
    End If
           
               
    pvtFormatToSort = s2 & s3
End Function


Private Function pvtFormatToDisplay(s As String) As String
    Dim s1 As String, s2 As String
    Dim i As Long
   
    If s Like "[A-Za-z]#*" Then
        i = 2
    ElseIf s Like "[A-Za-z][A-Za-z]#*" Then
        i = 3
    ElseIf s Like "[A-Za-z][A-Za-z][A-Za-z]#*" Then
        i = 4
    End If
       
    s1 = Left(s, i - 1)
   
    Do While Mid(s, i, 1) = 0
        i = i + 1
    Loop
   
    s2 = Right(s, Len(s) - i + 1)
           
    pvtFormatToDisplay = s1 & s2
End Function

---

Thanks Paul, will test this code out on Monday and get back to you.

Cheers,
enjam

Slightly more efficient version

Code:

---

Option Explicit


Sub drv()
   
    Call LetterNumberSort(Range("A2:A10"))


End Sub




' composed of 1 to 3 letters, and then a number, with the length of this number ranging from 1 to 5 digits.
Sub LetterNumberSort(r As Range)
    Dim c As Range
    Dim i As Long
    Dim s As String
   
    With r
        For Each c In .Cells
            Call pvtFormatToSort(c)
        Next


        With .Parent.Sort
            .SortFields.Clear
            .SortFields.Add Key:=r, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange r
            .Header = xlNo
            .MatchCase = True
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
       
        For Each c In .Cells
            Call pvtFormatToDisplay(c)
        Next
    End With
End Sub




Private Sub pvtFormatToSort(r As Range)
    Dim s1 As String, s2 As String, s3 As String
   
    s1 = Trim(UCase(r.Value))
   
    If s1 Like "[A-Z]#*" Then
        s2 = Left(s1, 1) & "00"
        s3 = Right("00000" & Right(s1, Len(s1) - 1), 5)
       
    ElseIf s1 Like "[A-Z][A-Z]#*" Then
        s2 = Left(s1, 2) & "0"
        s3 = Right("00000" & Right(s1, Len(s1) - 2), 5)
       
   
    ElseIf s1 Like "[A-Z][A-Z][A-Z]#*" Then
        s2 = Left(s1, 3)
        s3 = Right("00000" & Right(s1, Len(s1) - 3), 5)
    End If
               
    r.Value = s2 & s3
End Sub


Private Sub pvtFormatToDisplay(r As Range)
    Dim s1 As String, s2 As String, s3 As String
    Dim i As Long
   
    s1 = r.Value
   
    If s1 Like "[A-Z]#*" Then
        i = 2
    ElseIf s1 Like "[A-Z][A-Z]#*" Then
        i = 3
    ElseIf s1 Like "[A-Z][A-Z][A-Z]#*" Then
        i = 4
    End If
       
    s2 = Left(s1, i - 1)
   
    Do While Mid(s1, i, 1) = 0
        i = i + 1
    Loop
   
    s3 = Right(s1, Len(s1) - i + 1)
           
    r.Value = s2 & s3
End Sub

---

If you're happy for the output to be a separate range from your input (rather than just sorting your input in situ) see Power Query solution table in colmn D of the attached where you right-click that table and choose Refresh to update.

Thank you Paul, that code works just as intended. I'm applying on a range that's quite a bit longer (280,000 rows); it takes a while, but does the job :)

Pascal, thanks also for your input. Unfortunately I can't leverage the performance advantage of PowerQuery here as the sorting needs to be done in situ.

I'd suggest to use VBA:

Code:

---

Sub M_snb()
  sn = Sheet1.Cells(1).CurrentRegion.Columns(1)

  With GetObject("new:{00000535-0000-0010-8000-00AA006D2EA4}")
    .Fields.Append "S", 129, 3
    .Fields.Append "N", 5
    .Open
       
    For j = 1 To UBound(sn)
      .AddNew
      .Fields("N") = StrReverse(Val(StrReverse(sn(j, 1))))
      .Fields("S") = Replace(sn(j, 1), .Fields("N"), "")
      .Update
    Next
    .Sort = "S,N"
     
    MsgBox Replace(Replace(.getstring, vbTab, ""), " ", "")
  End With
End Sub

---

or

Code:

---

Sub M_snb()
  sn = Sheet1.Cells(1).CurrentRegion.Columns(1)

  With GetObject("new:{00000535-0000-0010-8000-00AA006D2EA4}")
    .Fields.Append "S", 129, 3
    .Fields.Append "N", 5
    .Open
     
    For j = 1 To UBound(sn)
      .AddNew
      .Fields("N") = StrReverse(Val(StrReverse(sn(j, 1))))
      .Fields("S") = Replace(sn(j, 1), .Fields("N"), "")
      .Update
    Next
    .Sort = "S,N"
     
    sp = .getrows
    For j = 0 To UBound(sp, 2)
      sn(j + 1, 1) = Trim(sp(0, j)) & sp(1, j)
    Next
     
    Sheet1.Cells(1).CurrentRegion.Columns(1) = sn
  End With
End Sub

---

Quote:

---

Originally Posted by enjam

Pascal, thanks also for your input. Unfortunately I can't use the performance advantage of PowerQuery here as the sorting needs to be done in situ.

---

That's possible with Power Query and 2 lines of VBA. It takes 20 seconds here to sort 280,000 records in situ.

Quote:

---

Originally Posted by enjam

Thank you Paul, that code works just as intended. I'm applying on a range that's quite a bit longer (280,000 rows); it takes a while, but does the job :)

---

Paul's code does take a while to complete with 280,000 records; I saw it was going to take some time so I left it running and went and chopped down a tree and planted 4 in its place. On returning I found it took 2.5 hours.
Paul's code takes a long time to execute because there's no Application.ScreenUpdating = False, but more importantly because it writes and reads to the sheet so many times.
In the attached, I've applied a few tweaks to Paul's code to reduce the number of read/writes to the sheet to just 4.
This took the time down to less than 4 seconds for 280,000 records, which is much faster than Power Query.

There is another difference I noticed; if you have values with leading zeroes in the numeric part like CB002, this get's reduced to CB2, which the PQ offering doesn't change. It would only need a bit more of a tweak to Paul's code to stop this happening.

@snb,

For me, your both VBA code, gave error.

http://www.vbaexpress.com/forum/imag...AAAElFTkSuQmCC
Attachment 29059
Highlight this line:
.Fields("S") = Replace(sn(j, 1), .Fields("N"), "")

Quote:

---

Originally Posted by enjam

Thank you Paul, that code works just as intended. I'm applying on a range that's quite a bit longer (280,000 rows); it takes a while, but does the job :)

---

Sorry, if I had known you were talking about 280K entries, I would have used arrays (like I think P45cal did)

My fault was using a IMHO more straight-forward approach that I thought would be easier for you to integrate

If it still seems too slow, come on back, but p45cal's and snb's should work fine

Quote:

---

Originally Posted by Tom Jones

@snb,
Highlight this line:
.Fields("S") = Replace(sn(j, 1), .Fields("N"), "")

---

I think it's to do with the original ending in a zero. In the following, zzz is your recordset object:

Code:

---

?sn(j, 1)
FVR25180
?StrReverse(sn(j, 1))
08152RVF
?Val(StrReverse(sn(j, 1)))
 8152
?StrReverse(Val(StrReverse(sn(j, 1))))
2518
?zzz.Fields("N")
 2518
?Replace(sn(j, 1), zzz.Fields("N"), "")
FVR0

---

I put it in code tags to try to preserve spaces/invisible characters.
Although the last command produces a string, it's the execution of:
.Fields("S") = Replace(sn(j, 1), .Fields("N"), "")
which throws an error.
Doing a Val on a string starting with zero, the zero is ignored.
Still don't know why it throws an error though…

edit: could it be because it's trying to put more than a 3-character string in a field with a defined size of 3?

In that case:

Code:

---

Sub M_snb()
  sn = Sheet1.Cells(1).CurrentRegion.Columns(1)

  With GetObject("new:{00000535-0000-0010-8000-00AA006D2EA4}")
    .Fields.Append "S", 129, 3
    .Fields.Append "N", 5
    .Open
     
    For j = 1 To UBound(sn)
      .AddNew
      y = StrReverse(Val(StrReverse(sn(j, 1))))
      n = Left(sn(j, 1), InStr(sn(j, 1), y) - 1)
      y = y * 10 ^ (Len(sn(j, 1)) - Len(y) - Len(n))
      .Fields("S") = n
      .Fields("N") = y
      .Update
    Next
    .Sort = "S,N"
     
    sp = .getrows
    For j = 0 To UBound(sp, 2)
      sn(j + 1, 1) = Trim(sp(0, j)) & sp(1, j)
    Next
     
    Sheet1.Cells(1).CurrentRegion.Columns(1) = sn
  End With
End Sub

---

Hi snb, thanks for your help, your revised VBA code also have me an error.

Apologies Paul for not specifying the number of rows; I will be more mindful of this in future posts.

Pascal thank you very much, that code works just as intended, and rapidly too. Is it possible to have a table 14 columns wide (and 280,000 rows long) to be sorted in this order, based on Column A?

Quote:

---

Apologies Paul for not specifying the number of rows; I will be more mindful of this in future posts.

---

No problem - my personal first approach is to go with a simple approach, even if it's not as efficient as others. For 1000+ rows, I doubt there would be a perceptible wall clock time difference

280k rows requires a more efficient approach as P45cal and snb have said

I used P45cal's macro and 'generalized' it a bit to sort the block of data (.CurrentRegion) by the first column, and I assumed that you had headers

For testing in the attached (since the run time issue has been fixed) I just used a dozen rows and 14 columns, so try it with your real data

Code:

---


Option Explicit


Sub drv()
    Call LetterNumberSort(ActiveSheet.Cells(1, 1).CurrentRegion)
End Sub


' composed of 1 to 3 letters, and then a number, with the length of this number ranging from 1 to 5 digits.
Sub LetterNumberSort(r As Range)
    Dim i As Long
    Dim aryValues As Variant
    Dim s As String
    Dim r1 As Range
   
    With r
        Set r1 = .Cells(2, 1).Resize(.Rows.Count - 1, .Columns.Count)
       
        aryValues = .Columns(1).Value
   
   
        For i = 2 To UBound(aryValues, 1)
          Call pvtFormatToSort(aryValues(i, 1))
        Next
   
      .Columns(1).Value = aryValues
     
      With .Parent.Sort
        .SortFields.Clear
        .SortFields.Add Key:=r1.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange r
        .Header = xlYes    '  <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
        .MatchCase = True
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
      End With
     
      aryValues = .Columns(1).Value
     
      For i = 2 To UBound(aryValues)
        Call pvtFormatToDisplay(aryValues(i, 1))
      Next
     
      .Columns(1).Value = aryValues
    End With
End Sub


'1. objects are always passed ByRef
'2. r should be Dim-ed as a Range since it is a Range, and not a Variant
'3. I originally had these as Functions, but that way forces VBA to make copies of the strings
Private Sub pvtFormatToSort(r As Range)
    Dim s1 As String, s2 As String, s3 As String
       
    s1 = Trim(UCase(r))
       
    If s1 Like "[A-Z]#*" Then
      s2 = Left(s1, 1) & "00"
      s3 = Right("00000" & Right(s1, Len(s1) - 1), 5)
           
    ElseIf s1 Like "[A-Z][A-Z]#*" Then
      s2 = Left(s1, 2) & "0"
      s3 = Right("00000" & Right(s1, Len(s1) - 2), 5)
           
       
    ElseIf s1 Like "[A-Z][A-Z][A-Z]#*" Then
      s2 = Left(s1, 3)
      s3 = Right("00000" & Right(s1, Len(s1) - 3), 5)
    End If
                   
    r = s2 & s3
End Sub




Private Sub pvtFormatToDisplay(r As Range)
    Dim s1 As String, s2 As String, s3 As String
    Dim i As Long
       
    s1 = r
       
    If s1 Like "[A-Z]#*" Then
      i = 2
    ElseIf s1 Like "[A-Z][A-Z]#*" Then
      i = 3
    ElseIf s1 Like "[A-Z][A-Z][A-Z]#*" Then
      i = 4
    End If
           
    s2 = Left(s1, i - 1)
       
    Do While Mid(s1, i, 1) = 0
      i = i + 1
    Loop
       
    s3 = Right(s1, Len(s1) - i + 1)
               
    r = s2 & s3
End Sub

---

Are you always so lazy ?
Why don't you mention the 'error' ?
Why don't you indicate in which line the 'error' occurs ?
Why don't try to find out what could cause the 'problem'?
Why don't you even post a sample workbook ?
How can we know in which workbook you will apply the macro?
If you use this code in PH's sample workbook you will see that it will ignore the column label, that obviously has no number in it.

Code:

---

Sub M_snb()
  sn = Sheet1.Columns(1).SpecialCells(2).Offset(1).SpecialCells(2)

  With GetObject("new:{00000535-0000-0010-8000-00AA006D2EA4}")
    .Fields.Append "S", 129, 3
    .Fields.Append "N", 5
    .Open
     
    For j = 1 To UBound(sn)
      .AddNew
      y = StrReverse(Val(StrReverse(sn(j, 1))))
      n = Left(sn(j, 1), InStr(sn(j, 1), y) - 1)
      y = y * 10 ^ (Len(sn(j, 1)) - Len(y) - Len(n))
      .Fields("S") = n
      .Fields("N") = y
      .Update
    Next
    .Sort = "S,N"
     
    sp = .getrows
    For j = 0 To UBound(sp, 2)
      sn(j + 1, 1) = Trim(sp(0, j)) & sp(1, j)
    Next
     
    Sheet1.Columns(1).SpecialCells(2).Offset(1).SpecialCells(2) = sn
  End With
End Sub

---

Very sorry snb, I responded to these posts during the limited time I had during lunchbreak and can appreciate your frustration over the lack of detail in my response.

I have tested your code on PH's workbook and can confirm that it produces the desired output. Thank you.

Quote:

---

Originally Posted by Paul_Hossler

'1. objects are always passed ByRef
'2. r should be Dim-ed as a Range since it is a Range, and not a Variant
'3. I originally had these as Functions, but that way forces VBA to make copies of the strings

---

Paul,
you're right about point 1, my ByRef was superfluous.
About point 2 I'm not so sure. The r in the pvtFormatToSort sub was not meant to be a range but a value/member in the aryValues array. The r in that sub is a different r from that in the LetterNumberSort sub (scope and all that). I tried running your code and was immediately met with a ByRef argument type mismatch error, which I'm nigh on certain is because you've Dim-med it as a range.
Re. point 3, I'm going to have an explore of making them into functions, but later…

Quote:

---

Originally Posted by snb

Why don't you even post a sample workbook ?

---

Exactly.

Faster alternative to randomize

Code:

---

Sub M_snb()
  Dim sn(28 * 10 ^ 4, 0)
  Randomize
 
  For j = 1 To UBound(sn)
    sn(j, 0) = Mid(Join(Array(Chr(65 + Int(25 * Rnd)), Chr(65 + (25 * Rnd)), Chr(65 + Int(26 * Rnd)), CLng(10 ^ 5 * Rnd)), ""), 1 + Int(3 * Rnd))
  Next
   
  Sheet1.Cells(1, 4).Resize(UBound(sn) + 1) = sn
End Sub

---

Quote:

---

Originally Posted by p45cal

Paul,
About point 2 I'm not so sure. The r in the pvtFormatToSort sub was not meant to be a range but a value/member in the aryValues array. The r in that sub is a different r from that in the LetterNumberSort sub (scope and all that). I tried running your code and was immediately met with a ByRef argument type mismatch error, which I'm nigh on certain is because you've Dim-med it as a range.

---

Yea, you are 100% correct. :blush:blush:blush

In my second ('Sub' version) version I was passing a Range to the sub, but in your improved version using arrays, it should have been a Variant.

That was a change I made at the last minute using the "I don't need to test THIS little change" rule. :banghead::banghead:

Code:

---


Private Sub pvtFormatToSort(r As Variant)

Private Sub pvtFormatToDisplay(r As Variant)

---

Quote:

---

Originally Posted by p45cal

Re. point 3, I'm going to have an explore of making them into functions, but later…

---

I was going by this (FWIW) figuring that the default ByRef in a Sub would save time taking the return from a Function and putting it back where it came from since the Sub would be operating on the 'real' parameter via it's address

https://www.aivosto.com/articles/stringopt.html#whyslow

Quote:

---

Pass strings ByRef

How should you define procedure parameters for calls from within the same project?
ByVal is slow for string parameters. ByVal makes a copy of the string on every call. The good side is that a ByVal parameter is safe to modify: the modifications aren't passed back to the callers.
ByRef is faster because the string doesn't get copied. The drawback is that you have to be careful. If your intention is not to return a value in the ByRef parameter back to the caller, you may not accidentally write to this parameter.
Use ByRef instead of function return value

There's also an optimization trick for returning a string value. Returning a string as the function return value is the normal practice. However, returning a string in a ByRef parameter is faster.

---

Alternative:

Code:

---

Sub M_snb()
  sn = Sheet1.ListObjects(1).DataBodyRange
 
  For j = 1 To UBound(sn)
    y = Val(StrReverse(sn(j, 1) & "9"))
    y = Len(sn(j, 1)) + 1 - Len(y)
    sn(j, 1) = Left(sn(j, 1), y) & Format(Mid(sn(j, 1), 1 + y), "00000")
  Next
 
  Cells(1, 10).Resize(UBound(sn)) = sn
  With Columns(10)
    .SpecialCells(2).Sort Cells(1, 10)
    sn = Columns(10).SpecialCells(2)
    .ClearContents
  End With
 
  For j = 1 To UBound(sn)
    y = Val(StrReverse(sn(j, 1) & "9"))
    y = Len(sn(j, 1)) + 1 - Len(y)
    sn(j, 1) = Left(sn(j, 1), y) & Val(Mid(sn(j, 1), 1 + y))
  Next
 
  Sheet1.ListObjects(1).DataBodyRange = sn
End Sub

---