Consulting

Page 1 of 2 1 2 LastLast
Results 1 to 20 of 23

Thread: Sorting based on letter, and then on number

  1. #1
    VBAX Regular
    Joined
    Dec 2016
    Posts
    17
    Location

    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

  2. #2
    VBAX Regular
    Joined
    Sep 2021
    Location
    INDIA
    Posts
    8
    Location
    Use This Code if it is help full to you or not


    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

  3. #3
    VBAX Regular
    Joined
    Dec 2016
    Posts
    17
    Location
    Thanks for your reply Prasadk, unfortunately the code does not achieve the desired output

  4. #4
    VBAX Sage
    Joined
    Apr 2007
    Posts
    8,027
    Location
    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


    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
    Attached Files Attached Files
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  5. #5
    VBAX Regular
    Joined
    Dec 2016
    Posts
    17
    Location
    Thanks Paul, will test this code out on Monday and get back to you.

    Cheers,
    enjam

  6. #6
    VBAX Sage
    Joined
    Apr 2007
    Posts
    8,027
    Location
    Slightly more efficient version

    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
    Attached Files Attached Files
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  7. #7
    Knowledge Base Approver VBAX Wizard
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,447
    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.
    Attached Files Attached Files
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  8. #8
    VBAX Regular
    Joined
    Dec 2016
    Posts
    17
    Location
    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.

  9. #9
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,259
    I'd suggest to use VBA:

    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

    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
    Last edited by snb; 10-18-2021 at 06:52 AM.

  10. #10
    Knowledge Base Approver VBAX Wizard
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,447
    Quote Originally Posted by enjam View Post
    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 View Post
    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.
    Attached Files Attached Files
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  11. #11
    @snb,

    For me, your both VBA code, gave error.


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

  12. #12
    VBAX Sage
    Joined
    Apr 2007
    Posts
    8,027
    Location
    Quote Originally Posted by enjam View Post
    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
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  13. #13
    Knowledge Base Approver VBAX Wizard
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,447
    Quote Originally Posted by Tom Jones View Post
    @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:
    ?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?
    Last edited by p45cal; 10-18-2021 at 01:42 PM.
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  14. #14
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,259
    In that case:

    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

  15. #15
    VBAX Regular
    Joined
    Dec 2016
    Posts
    17
    Location
    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?

  16. #16
    VBAX Sage
    Joined
    Apr 2007
    Posts
    8,027
    Location
    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

    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
    Attached Files Attached Files
    Last edited by Paul_Hossler; 10-19-2021 at 12:18 AM.
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  17. #17
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,259
    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.

    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

  18. #18
    VBAX Regular
    Joined
    Dec 2016
    Posts
    17
    Location
    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.

  19. #19
    Knowledge Base Approver VBAX Wizard
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,447
    Quote Originally Posted by Paul_Hossler View Post
    '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…
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  20. #20
    Knowledge Base Approver VBAX Wizard
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,447
    Quote Originally Posted by snb View Post
    Why don't you even post a sample workbook ?
    Exactly.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •