Extracting string of 10 Numbers from cell

[de_keda]

I have a column of thousands of cells that contain responses from a survey. Each cell contains an account number (or should) of exactly 10 numbers, but at different positions in the cell. The cell can also contain other numbers, but I need to extract just the 10-digit account number from each cell to another cell.

Example(1):
aa9876 reviewed 1234567891 and proceeded to credit $10

Example(2):
2345678912 completed

Example(3):
$50 credit. 3456789123 done. 3ab456 approved

Because this is a survey-type response, the user can enter anything they wish and submit it. But each response *should* contain the 10-digit account number.

I found and slightly modified the following CSE array formula (though I don't really understand it), but it only returns the first 10 numbers in the cell; as the account number is not always the first thing entered, it does not help:
=LEFT(SUM(MID(0&C31,LARGE(ISNUMBER(--MID(C31,ROW(INDIRECT("1:"&LEN(C31))),1))*ROW(INDIRECT("1:"&LEN(C31))),ROW(INDIRECT("1:"&LEN(C31))))+1,1)*10^ROW(INDIRECT("1:"&LEN(C31)))/10),10)

I need a formula that will search for the string of the 10-digit account number and return only that number, regardless of what other text/numbers are in the cell.

Thanks in advance!!!

 

[Rick Rothstein]

Yes it will. But in terms of efficiency, it will unnecessarily "clean"
every element of the Split -- even those that do not have 10 digits.

I would also replace 'GoTo MyExit' with 'Exit For'.

Fair points (one of the problems with modifying someone else's code is you do not always see things you might have accounted for if you did the code from scratch). Still sticking with hiker's code, I think this new modification addresses your points...

Private Sub Worksheet_Change(ByVal Target As Range)
  ' hiker95, 11/17/2016, ME976552
  Dim s As Variant, i As Long, x As Long
  If Intersect(Target, Range("C2:C10000")) Is Nothing Then Exit Sub
  If Target.Count > 1 Then Exit Sub
  If Target = "" Then Target.Offset(, 1).ClearContents: Exit Sub
  With Application
    .EnableEvents = False
    .ScreenUpdating = False
    s = Split(Target, " ")
    For i = 0 To UBound(s)
      For x = 1 To Len(s(i))
        If s(i) Like "*##########*" Then
          If Mid(s(i), x, 1) Like "[!A-Za-z0-9]" Then Mid(s(i), x) = " "
        End If
      Next
      If Trim(s(i)) Like "##########" Then
        Target.Offset(, 1).NumberFormat = "General"
        Target.Offset(, 1).Value = s(i)
        .Columns(4).AutoFit
        Exit For
      End If
    Next i
    .EnableEvents = True
    .ScreenUpdating = True
  End With
End Sub

 

[Tetra201]

... problems with modifying someone else's code...

I hesitated to post because it were you and hiker95 who did all the heavy lifting, but here is what I had when I wrote Post #8:

Private Sub Worksheet_Change(ByVal Target As Range)
    ' hiker95, 11/17/2016, ME976552
    Dim s As Variant, i As Long, x As Long
    If Intersect(Target, Range("C2:C10000")) Is Nothing Then Exit Sub
    If Target.Count > 1 Then Exit Sub
    If Target = "" Then Target.Offset(, 1).ClearContents: Exit Sub
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
        s = Split(Target, " ")
        For i = 0 To UBound(s)
            If s(i) Like "*##########*" Then
                tmpStr = s(i)
                For j = 1 To Len(tmpStr)
                    If Mid(tmpStr, j, 1) Like "[!0-9]" Then Mid(tmpStr, j, 1) = " "
                Next j
                Target.Offset(, 1).NumberFormat = "@"
                Target.Offset(, 1).Value = Trim(tmpStr)
                .Columns(4).AutoFit
                Exit For
            End If
        Next i
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

 

[Rick Rothstein]

I hesitated to post because it were you and hiker95 who did all the heavy lifting, but here is what I had when I wrote Post #8:

Private Sub Worksheet_Change(ByVal Target As Range)
    ' hiker95, 11/17/2016, ME976552
    Dim s As Variant, i As Long, x As Long
    If Intersect(Target, Range("C2:C10000")) Is Nothing Then Exit Sub
    If Target.Count > 1 Then Exit Sub
    If Target = "" Then Target.Offset(, 1).ClearContents: Exit Sub
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
        s = Split(Target, " ")
        For i = 0 To UBound(s)
            If s(i) Like "*##########*" Then
                tmpStr = s(i)
                For j = 1 To Len(tmpStr)
                    If Mid(tmpStr, j, 1) Like "[!0-9]" Then Mid(tmpStr, j, 1) = " "
                Next j
                Target.Offset(, 1).NumberFormat = "@"
                Target.Offset(, 1).Value = Trim(tmpStr)
                .Columns(4).AutoFit
                Exit For
            End If
        Next i
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

Don't ever hesitate... all contributions are always welcome. In this case, I like your code arrangement better than what I came up with.

 

[Sektor]

Function GetNumber(cell)
    With CreateObject("VBScript.RegExp")
        .Pattern = "\d{10}"
        With .Execute(cell)
            If .Count > 0 Then GetNumber = .Item(0) Else GetNumber = ""
        End With
    End With
End Function

 

[Rick Rothstein]

Function GetNumber(cell)
    With CreateObject("VBScript.RegExp")
        .Pattern = "\d{10}"
        With .Execute(cell)
            If .Count > 0 Then GetNumber = .Item(0) Else GetNumber = ""
        End With
    End With
End Function

Fails for numbers longer than 10 digits...

"Bad number 1234567890123 followed by 9876543210 which is the desired number"

also picks up 10-digit numbers not surrounded by spaces or punctuations...

"Bad number abc1234567890def followed by 9876543210 the good number"

 

[Sektor]

Fails for numbers longer than 10 digits...

"Bad number 1234567890123 followed by 9876543210 which is the desired number"

also picks up 10-digit numbers not surrounded by spaces or punctuations...

"Bad number abc1234567890def followed by 9876543210 the good number"

The OP said "but I need to extract just the 10-digit account number "

 

[Rick Rothstein]

The OP said "but I need to extract just the 10-digit account number "

I know... and in both my examples, that 10-digit number is located at the end and you formula does not find it (in the first example, it gets the first 10 digits from the 13-digit number and in the second example it ignores the attached text and picks the 10 digits attached to the text instead of finding the stand-alone 10-tigit number after it).

 

[Sektor]

@Rick Rothstein

Function GetNumber(cell)
    With CreateObject("VBScript.RegExp")
        .Pattern = "\b\d{10}\b"
        With .Execute(cell)
            If .Count > 0 Then GetNumber = .Item(0) Else GetNumber = "Not Found"
        End With
    End With
End Function

 

[István Hirsch]

If you need a formula solution, please check this one:

=MID(A1,FIND(" "&REPT("|",10)&" ",SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(" "&A1&" ","0","|"),"1","|"),"2","|"),"3","|"),"4","|"),"5","|"),"6","|"),"7","|"),"8","|"),"9","|"),REPT("|",10)&",",REPT("|",10)&" "),REPT("|",10)&".",REPT("|",10)&" "),REPT("|",10)&":",REPT("|",10)&" "),REPT("|",10)&";",REPT("|",10)&" ")),10)

 

[de_keda]

I hesitated to post because it were you and hiker95 who did all the heavy lifting, but here is what I had when I wrote Post #8:

Private Sub Worksheet_Change(ByVal Target As Range)
     ' hiker95, 11/17/2016, ME976552
     Dim s As Variant, i As Long, x As Long
     If Intersect(Target, Range("C2:C10000")) Is Nothing Then Exit Sub
     If Target.Count > 1 Then Exit Sub
     If Target = "" Then Target.Offset(, 1).ClearContents: Exit Sub
     With Application
         .EnableEvents = False
         .ScreenUpdating = False
         s = Split(Target, " ")
         For i = 0 To UBound(s)
             If s(i) Like "*##########*" Then
                 tmpStr = s(i)
                 For j = 1 To Len(tmpStr)
                     If Mid(tmpStr, j, 1) Like "[!0-9]" Then Mid(tmpStr, j, 1) = " "
                 Next j
                Target.Offset(, 1).NumberFormat = "@"
                 Target.Offset(, 1).Value = Trim(tmpStr)
                 .Columns(4).AutoFit
                 Exit For
             End If
         Next i
         .EnableEvents = True
         .ScreenUpdating = True
     End With
 End Sub

Don't ever hesitate... all contributions are always welcome. In this case, I like your code arrangement better than what I came up with.

Rick, Tetra, and everyone who replied I want to say thank you very much! I apologize for the delay in responding; I was traveling due to holidays.

I'm not sure what I'm doing wrong, but I'm not getting these codes to work. I've tried several of them, and followed the instructions given as best I can, and nothing seems to happen at all. I right clicked, selected "view code", pasted it in the vba worksheet, saved the file as ".xlsm", and......nothing happens. I assume that as it's a "Worksheet_Change" macro, it will run whenever a cell on the worksheet is changed. But nope, can't get anything to happen at all. Nothing happens in Column D when I paste new information, or change any of the existing cells in Column C. It's as though the code isn't running.

I tried pasting the code in a Module and adding a form control button to click and make it run, but I'm not getting any luck there either. Running into all sorts of issues dealing with the "ByVal" and trying to turn in into a "regular" module macro, or calling the sub (which is requiring an argument), etc etc all of which are a bit beyond me at this point.

What am I doing wrong with pasting the code in the sheet?