Funtion to extract numbers from a rangeof cells

[aurelius89]

I have found a function that extracts the numbers from a cell:

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

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

I have tested this in my sheet by using =ExtractNumber(A1) and it works fine. If HBGR2342 was in cell A1 it would return 2342 as expected.

I now need to incorporate this in VBA to perform the number extraction on a range. I have put together the below but it doesn't work.

Sub TakeNumbers()
   Dim ws As Worksheet
   Set ws = ThisWorkbook.Worksheets("RefindData")
   
   Dim c As Range
       For Each c In ws.Range("G2:G2500").Cells
            Call ExtractNumber(c)
        Next c
End Sub

How can I make this function perform on a range of cells?

 

[MickG]

You could perhaps use the code below for data in column "A" and results in column "B".

[COLOR="Navy"]Sub[/COLOR] MG31May23
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, nStr [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
[COLOR="Navy"]For[/COLOR] n = 1 To Len(Dn.Value)
    [COLOR="Navy"]If[/COLOR] Dn.Characters(n, 1).Text Like "[0-9]" [COLOR="Navy"]Then[/COLOR]
        nStr = nStr & Dn.Characters(n, 1).Text
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] n
Dn.Offset(, 1) = Val(nStr): nStr = ""
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[aurelius89]

Thanks Mick,

Got this working now, just need it to copy the output over the original input and clear the output

I got this far, but not sure how to accurately capture the output range:

Sub MG31May23()

Dim Rng As Range, Dn As Range, nStr As String, n As Long

Dim OutputRng As Range

Set Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))

For Each Dn In Rng

For n = 1 To Len(Dn.Value)
    If Dn.Characters(n, 1).Text Like "[0-9]" Then
        nStr = nStr & Dn.Characters(n, 1).Text
    End If
Next n

Dn.Offset(, 5) = Val(nStr): nStr = ""

Next Dn

Set OutputRng = ???

Rng.Value = OutputRng.Value
Rng.ClearContents

End Sub

 

[aurelius89]

Never mind I didn't need to do any of that, just took out the offset

 

[Rick Rothstein]

If HBGR2342 was in cell A1 it would return 2342 as expected.

Does all of the text in all of your cells look like this example... a bunch of letters followed by the number you want (where the numbers are always at the end of the text)?

If yes, is that number always 4 digits long?

 

[aurelius89]

80% of the time it will be 1 letter and 2 numbers, but unfortunately I have to account for the other 20% of the time when it could be any amount of letters followed by any amount of numbers.

I have a new issue with this though. My version of it is causing an unable to get the text property of the characters class error on a line that has not changed from the original:

Sub ExtractNumbersInColumn(ColWithNums As String)

Dim Rng As Range, Dn As Range, nStr As String, n As Long
Dim wb As Workbook
Dim ws As Worksheet
Dim ColToUse As String

Set wb = ThisWorkbook
Set ws = wb.Sheets("RefindData")

Dim rngStart As Range
Dim rngEnd As Range

Set rngStart = ws.Range(ColWithNums & "2")
Debug.Print rngStart.Address
Set rngEnd = ws.Range(ColWithNums & Rows.Count).End(xlUp)
Debug.Print rngEnd.Address
Set Rng = ws.Range(rngStart, rngEnd)
Debug.Print Rng.Address

For Each Dn In Rng

For n = 1 To Len(Dn.Value)
    If Dn.Characters(n, 1).Text Like "[0-9]" Then
        nStr = nStr & Dn.Characters(n, 1).Text
    End If
Next n

Dn = Val(nStr): nStr = ""

Next Dn

End Sub

It is this one:

 If Dn.Characters(n, 1).Text Like "[0-9]" Then

Yet the version in my other post worked fine.....

 

[aurelius89]

Ok, I have discovered that it does not like to look at a cell containing only numbers otherwise <code style="margin: 0px; padding: 1px 5px; border: 0px; font-variant-numeric: inherit; font-stretch: inherit; line-height: inherit; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; vertical-align: baseline; background-color: rgb(239, 240, 241); white-space: pre-wrap; color: rgb(36, 39, 41);">.Text</code> will kick up a fuss....

So the real question now is how can I alter this for it to be happy looking at cells that contain letters and numbers, as well as just numbers (but not do anything with obviously)