OzGrid Excel and VBA Newsletter December 2006

Excel Finance & Statistic Learning. The source code of these Excel files is unprotected for learning purposes.

'MUST be at top of same public module housing _
Sub SortAlphaNumerics and Function ExtractNumber
Dim bDec As Boolean, bNeg As Boolean

Sub SortAlphaNumerics()
Dim wSheetTemp As Worksheet
Dim wsStart As Worksheet
Dim lLastRow As Long, lReply As Long
Dim rSort As Range

     ''''''''''''''''''''''''''''''''''''''''''
     '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
     
     ''''''''''''''''''''''''''''''''''''''''''

   
    Set wsStart = ActiveSheet
    
   On Error Resume Next
   Set rSort = Application.InputBox _
        ("Select range to sort. Any heading should be bolded and included", "ALPHANUMERIC SORT", _
        ActiveCell.CurrentRegion.Columns(1).Address, , , , , 8)
    
        If rSort Is Nothing Then Exit Sub
        
        If rSort.Columns.Count > 1 Then
           MsgBox "Single Column Only"
           SortAlphaNumerics
        End If
           
    
        'Application.ScreenUpdating = False
        Set rSort = Range(Cells(rSort.Cells(1, 1).Row, rSort.Column), _
            Cells(Rows.Count, rSort.Column).End(xlUp))
            
       lReply = MsgBox("Include Decimals within numbers", vbYesNoCancel, "OZGRID ALPHANUMERIC SORT")
       If lReply = vbCancel Then Exit Sub
       
       bDec = lReply = vbYes
       
       lReply = MsgBox("Include negative signs within numbers", vbYesNoCancel, "OZGRID ALPHANUMERIC SORT")
       If lReply = vbCancel Then Exit Sub
       
       bNeg = lReply = vbYes
        
        lLastRow = rSort.Cells(rSort.Rows.Count).Row
   
        Set wSheetTemp = Worksheets.Add
        rSort.Copy wSheetTemp.Range("A1")

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



Function ExtractNumber(rCell As Range, _
    Optional Take_decimal As Boolean, Optional Take_negative As Boolean) As Double
    
    Dim iCount As Integer, i As Integer, iLoop As Integer
    Dim sText As String, strNeg As String, strDec As String
    Dim lNum As String
    Dim vVal, vVal2
     
     ''''''''''''''''''''''''''''''''''''''''''
     'Written by OzGrid Business Applications
     'www.ozgrid.com
     
     'Extracts a number from a cell containing text and numbers.
     ''''''''''''''''''''''''''''''''''''''''''
    sText = rCell
    If Take_decimal = True And Take_negative = True Then
        strNeg = "-" 'Negative Sign MUST be before 1st number.
        strDec = "."
    ElseIf Take_decimal = True And Take_negative = False Then
        strNeg = vbNullString
        strDec = "."
    ElseIf Take_decimal = False And Take_negative = True Then
        strNeg = "-"
        strDec = vbNullString
    End If
    iLoop = Len(sText)
        
            For iCount = iLoop To 1 Step -1
            vVal = Mid(sText, iCount, 1)
            
    
                If IsNumeric(vVal) Or vVal = strNeg Or vVal = strDec Then
                    i = i + 1
                    lNum = Mid(sText, iCount, 1) & lNum
                        If IsNumeric(lNum) Then
                            If CDbl(lNum) < 0 Then Exit For
                        Else
                          lNum = Replace(lNum, Left(lNum, 1), "", , 1)
                        End If
                End If
                 
                If i = 1 And lNum <> vbNullString Then lNum = CDbl(Mid(lNum, 1, 1))
            Next iCount
        
     
    ExtractNumber = CDbl(lNum)
     
End Function