Extract numeric value from a cell

[Nelson78]

Hello everybody.


I've a problem about one of my Excel works that I'm trying to solve unsuccessfully.

There are two columns (F and G) populated by phone numbers. Unfortunately, these phone numbers are "alterated" by alphabetic characters, spaces (" ") or special characters ("/", "_", ecc).

Example of "altereted" numbers:
335 1234567
336/1234567
TEL3371234567
I need to extract numeric characters and rewriting on the same cell with a vba code.

Example of correct numbers.
3351234567
3361234567
3371234567

Seep into consideration that the operation must be repeted from row 2 until column F is populated.
Something like:
LR = Cells(Rows.Count, "F").End(xlUp).Row
For Each Cell In Range("F2:G" & LR)



Thank you in advance for your help.


Nelson78

 

[Kenneth Hobson]

Welcome to the forum!

As always, test on a backup copy. In a Module:

Sub Main()
  Dim c As Range
  With CreateObject("VBScript.RegExp")
    .Pattern = "\D*"
    .Global = True
    For Each c In Intersect(ActiveSheet.UsedRange, Range("F2:G" & Rows.Count))
      c.Value = .Replace(c.Value, "")
    Next c
  End With
End Sub

 

[Nelson78]

First of all, thank you for the answers.

The test has been successfull (a section of 20 rows).

Now i'm trying on the entire file (5000 rows): the system is processing from 2 hours. Could it be a normal duration?

 

[Kenneth Hobson]

You can manually speed those sorts of things by setting automatic calculation to manual. Of course we can do that using the Application commands as well. Screen updating, events, and alerts can be set that way too. I would show you that way but the fastest method is to write back just once. Arrays make that easy.

In this example, FillFG() is not needed. I showed it so you can easily test on a blank sheet as I did if you like.

Sub Main()
  Dim r As Long, c As Integer, a
  
  With CreateObject("VBScript.RegExp")
    .Pattern = "\D*"
    .Global = True
    a = Intersect(ActiveSheet.UsedRange, Range("F2:G" & Rows.Count)).Value
    For r = 1 To UBound(a, 1)
      For c = 1 To UBound(a, 2)
        a(r, c) = .Replace(a(r, c), "")
      Next c
    Next r
  End With
  
  With Range("F2").Resize(UBound(a, 1), UBound(a, 2))
    .Value = a
    .EntireColumn.AutoFit
  End With
End Sub

Sub FillFG()
  Dim a(1 To 5000, 1 To 2), i As Integer, j As Integer
  For i = 1 To 5000
    For j = 1 To 2
      a(i, j) = i + 1 & ", " & j
    Next j
  Next i
  
  Range("F2").Resize(5000, 2).Value = a
  'Range("F2:G5001").Value = "335 1234567"
End Sub

 

[Nelson78]

Thank you for spending you time in my troubles.

The second solution is instantaneous, with 5000 records as well.
Now, i need a little bit of time for studying your method in order to apply it when needed.

But before, just a (naive) question: why did you firstly propose the slower solution?

 

[Kenneth Hobson]

Speed only matters for large datasets. Plus, I am lazy. Speed can usually be increased by one of several means. A solution concept is what I usually focus on.

Arrays are most always the fastest method. For the Application speedup commands, I normally use this sort of thing. See the Yours() routine for example use of these.

'http://vbaexpress.com/kb/getarticle.php?kb_id=1035
Public glb_origCalculationMode As Integer

Sub SpeedOn(Optional StatusBarMsg As String = "Running macro...")
  glb_origCalculationMode = Application.Calculation
  With Application
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
    .Cursor = xlWait
    .StatusBar = StatusBarMsg
    .EnableCancelKey = xlErrorHandler
  End With
End Sub

Sub SpeedOff()
  With Application
    .Calculation = glb_origCalculationMode
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .CalculateBeforeSave = True
    .Cursor = xlDefault
    .StatusBar = False
    .EnableCancelKey = xlInterrupt
  End With
End Sub

Sub Yours()
    On Error GoTo EndSub
    SpeedOn
     
' your stuff here
     
EndSub:
    SpeedOff
End Sub

 

[Nelson78]

I'm analysing your solution. It's clear how to identify the a area, but now I'm focusing on the function CreateObject.

Pattern: \D is not numeric characters, ok. But what is the role of * ?

Global: in order to understand the logic, i've executed some empiric tests using "false", but it is no clear when it could be appropriate to use it (the only result is that the replace doesn't work).

Thank you.

 

[Kenneth Hobson]

There is a lot out there about the Regular Expression object. Wildcards common in it and Like() are * and ?. A few quick cheat sheets on RegEx may explain more: http://www.rexegg.com/regex-quickstart.html, https://www.cheatography.com/davechild/cheat-sheets/regular-expressions/

You lost me on the False thing.

 

[Nelson78]

No big problems about global "true" of "false", just understanding what means, but at the moment is not so important (well, with "true" the process is ok).

Now, i'm studying the link you've suggested.

One condition of my work - following that we have already examinated - is that number starting with "3" can have at maximum 10 digits (the reason is a concrete one: in my country, mobile phone number always starts with "3" and their length is maximum 10 digits). The digits in excess (the 11th, the 12th and so on) must be eliminated.

For example 33312345678 (11 digits) converted in 3331234567 (10 digits, "8" eliminated).

I don't know if the best way to solve it is regex, anyway I've composed this:

/^[0-9]{1,10}$?/

Is it correct for limiting the digits to ten?
And, if yes, how can we say (if possible with regex) to apply this rule just to number starting with "3"?


Many thanks as always.

 

[danners430]

Hey folks, just another option for you all - this is the function I use to remove Alpha characters from a string. It could probably be tweaked slightly if you needed it to.

If you insert this into a module:

Function removeAlpha(r As String) As IntegerWith CreateObject("vbscript.regexp")
    .Pattern = "[A-Za-z]"
    .Global = True
    removeAlpha = .Replace(r, "")
End With
End Function

and this into the sheet code:

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Column = XXX Then                           'insert column here
    Target.Cells = removealpha(Target.Cells.Value)
End If


End Sub

You might have to add other characters to the replace function, such as slash, dash etc.

your other option is to split the string into individual characters, then check each one for numeracy:

Function RemoveNonNumeric(r As String)Dim buff() As String
Dim i As Integer


buff = Split(StrConv(r, vbUnicode), Chr$(0))
ReDim Preserve buff(UBound(buff) - 1)


For i = 0 To UBound(buff)
    If IsNumeric(buff(i)) = True Then
        RemoveNonNumeric = RemoveNonNumeric & buff(i)
    End If
Next i


End Function

Again, add the same code as above to the worksheet page.

Let us know if this helps!