Sort AlphaNumeric Text By Numbers

Sub SortAlphaNumerics()
Dim wSheetTemp As Worksheet
Dim wsStart As Worksheet
Dim lLastRow As Long


     ''''''''''''''''''''''''''''''''''''''''''
     'Written by OzGrid Business Applications
     'www.ozgrid.com
     
     'Sorts Alphanumerics Of Column "A" of active Sheet.
     'ExtractNumber Function REQUIRED
     'http://www.ozgrid.com/VBA/ExtractNum.htm
     
     ''''''''''''''''''''''''''''''''''''''''''


    Application.ScreenUpdating = False
    Set wsStart = ActiveSheet
    Set wSheetTemp = Worksheets.Add


   With wsStart
        lLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        .Range("A1:A" & lLastRow).Copy _
        wSheetTemp.Range("A1")
   End With
    
    With wSheetTemp.Range("B1:B" & lLastRow)
        .FormulaR1C1 = "=ExtractNumber(RC[-1])"
        .Copy
        .PasteSpecial xlPasteValues
            Application.CutCopyMode = False
    End With
    
    With wSheetTemp.UsedRange
                .Sort Key1:=.Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
                    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                    DataOption1:=xlSortNormal
                .Columns(1).Cut wsStart.Range("A1")
    End With
    
    Application.DisplayAlerts = False
    wSheetTemp.Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
End Sub




Function ExtractNumber(rCell As Range) As Double
    Dim iCount As Integer, i As Integer
    Dim sText As String
    Dim lNum As String
    Dim vVal
     
     ''''''''''''''''''''''''''''''''''''''''''
     'Written by OzGrid Business Applications
     'www.ozgrid.com
     
     'Extracts a number from a cell containing text and numbers.
     ''''''''''''''''''''''''''''''''''''''''''
    sText = rCell
     
    For iCount = Len(sText) To 1 Step -1
    vVal = Mid(sText, iCount, 1)
        If IsNumeric(vVal) Or vVal = "." Or vVal = "-" Then
            i = i + 1
            lNum = Mid(sText, iCount, 1) & lNum
        End If
         
        If i = 1 Then lNum = CDbl(Mid(lNum, 1, 1))
    Next iCount
     
    ExtractNumber = CDbl(lNum)
     
End Function

Sub sortAlphaNumeric()


Dim i As Long       'Loop counter
Dim lrow As Long    'Last row of data


'Presumes sorting 1 column only
'Presumes Col as maximum extents of data
    
    Application.ScreenUpdating = False


    'Get last row of data Col A (+1 for first blank row)
    lrow = Range("A65536").End(xlUp).Row + 1
    
    'Variable for compare
    nrow = lrow
    
'Use empty space as storage, splitting cell values
    
    'Loop on all rows
    For i = 1 To lrow - 1
        'Get alpha
        Cells(nrow, 1) = Left(Cells(i, 1), 3)
        'Get numeric
        Cells(nrow, 2) = Right(Cells(i, 1), Len(Cells(i, 1)) - 3)
        'Increment row
        nrow = nrow + 1
    Next i
    
    'Sort by numeric then alpha
        Range(Cells(lrow, 1), Cells(nrow - 1, 2)).Select
        Selection.Sort _
        Key1:=Range("B" & lrow), Order1:=xlAscending, _
        Key2:=Range("A" & lrow), Order2:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom


'Copy/Paste back
    'where to work
    nrow = lrow
    'Loop on all cells
    For i = 1 To lrow - 1
        'Rebuild original values
        Cells(i, 1) = Cells(nrow, 1) & Cells(nrow, 2)
        'Increment row
        nrow = nrow + 1
    Next i
    
    'Delete temp(working)range
    Range(Cells(lrow, 1), Cells(nrow, 2)).ClearContents


End Sub

Sub sortAlphaNumericMulti()


Dim i As Long       'Loop counter
Dim lrow As Long    'Last row of data
Dim nrow As Long    'New lastrow after copy
Dim lcol As Long    'Last col of data, this row


'Presumes data in Col A and Row 1 has maximum extents


    'Get last row of data Col A (+1 for first blank row)
    lrow = Range("A65536").End(xlUp).Row + 1
    
    'Variable for compare
    nrow = lrow
    
    'Get last column of data (row 1)
    lcol = Range("IV1").End(xlToLeft).Column
    
'Use empty space as storage, splitting cell values
    
    'Loop on all rows
    For i = 1 To lrow - 1
        'Get alpha
        Cells(nrow, 1) = Left(Cells(i, 1), 3)
        'Get numeric
        Cells(nrow, 2) = Right(Cells(i, 1), Len(Cells(i, 1)) - 3)
        'Copy rest of data
        Range(Cells(i, 2), Cells(i, lcol)).Copy Cells(nrow, 3)
        'Increment row
        nrow = nrow + 1
    Next i


    'Sort by numeric then alpha
    Range(Cells(lrow, 1), Cells(nrow - 1, lcol + 1)).Select
    Selection.Sort _
        Key1:=Range("B" & lrow), Order1:=xlAscending, _
        Key2:=Range("A" & lrow), Order2:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom


'Copy/Paste back
    'where to work
    nrow = lrow
    'Loop on all cells
    For i = 1 To lrow - 1
        'Rebuild original values
        Cells(i, 1) = Cells(nrow, 1) & Cells(nrow, 2)
        
        'Copy sorted
        Range(Cells(nrow, 3), Cells(nrow, lcol + 1)).Copy Cells(i, 2)
        
        'Increment row
        nrow = nrow + 1
    Next i
    
    'Delete temp(working)range
    Range(Cells(lrow, 1), Cells(nrow - 1, lcol + 1)).ClearContents


    Application.ScreenUpdating = True


End Sub