Pulling complicated numbers.

[Ingolf]

Hello,


In cell A1 are several phrases containing words and numbers. The numbers are separated by words, less the ten numbers which are consecutive and separated by commas.
How can I extract the numbers of those phrases. One of numbers have 13 digits, one has 7 digits and one or more 10-digit numbers that start with 0 (zero). I would like to extract those numbers in separate columns, except ten-digit numbers, I want in the same cell separated by commas.
In the same phrase it is also an email address that I want to draw it in a separate column.

In cell A2...A10 it is other phrases with same pattern.
One number with 13 digits
One number with 7 digits
One or more numbers (starting with Zero) separated by commas.
Email address

Need a VBA code.
Thank you.

 

[Ingolf]

Rick, thank you very much.
As usual, if the problem is exposed well, your answer is perfect. excellent.
Excellent job. You're the best. Million thanks.

 

[Ingolf]

Rick,

If the email address, has numbers , the address is not copied properly

Excel Workbook
	A	B	C
3	Concern is led by DL. JAMIE BROWN, whose account 1550101223356. Contact phone number is 0155214542 and 0994578452. PROVIDER THINGS IS FREE TRADE SC, number 1122334, with BJ545RTY indicator. For additional information using the email address drres26.dust@gmail.com	1550101223356	dust@gmail.com
4	Concern is led by DL. JAMIE BROWN, whose account 1550101223356. Contact phone number is 0155214542, 0994578452, 0114115887. PROVIDER THINGS IS FREE TRADE SC, number 1122334, with BJ545RTY indicator. For additional information using the email address drr88esAA.dust@gmail.com	1550101223356	sAA.dust@gmail.com
Sheet1

 

[Rick Rothstein]

Rick,

If the email address, has numbers , the address is not copied properly

Yeah, I was a little worried about the problems the email address might cause. In order to handle it properly, I revised my code and included a function for it to use to retrieve the email address separately (so make sure you copy all of the following code and use it to replace what I previously posted)...

[table="width: 500"]
[tr]
	[td]Sub RetrieveNumbers()
  Dim X As Long, Cell As Range, CellText As String, Email As String, Result As Variant, Parts() As String
  For Each Cell In Range("A2", Cells(Rows.Count, "A").End(xlUp))
    Email = GetEmailAddress(Cell.Value)
    CellText = Replace(Cell.Value, Email, " ")
    For X = 1 To Len(Cell.Value) - 1
      If Mid(CellText, X, 2) Like "#[!0-9A-Z ]" Then Mid(CellText, X + 1) = " "
    Next
    Parts = Split(Application.Trim(CellText))
    ReDim Result(1 To 1, 1 To 5)
    For X = 0 To UBound(Parts)
      If Parts(X) Like "#############" Then
        Result(1, 1) = Parts(X)
      ElseIf Parts(X) Like "##########" Then
        Result(1, 3) = Result(1, 3) & ", " & Parts(X)
      ElseIf Parts(X) Like "#######" Then
        Result(1, 5) = Parts(X)
      ElseIf Parts(X) Like "[A-Z][A-Z]###[A-Z][A-Z][A-Z]" Then
        Result(1, 4) = Parts(X)
      End If
    Next
    Result(1, 2) = Email
    Result(1, 3) = Mid(Result(1, 3), 3)
    Cell.Offset(, 1).Resize(, 5).NumberFormat = "@"
    Cell.Offset(, 1).Resize(, 5) = Result
  Next
End Sub

Function GetEmailAddress(ByVal S As String, Optional StartAt As Long = 1) As String
  Dim X As Long, AtSign As Long
  Dim Locale As String, Domain As String
  S = Mid(S, StartAt)
  Locale = "[A-Za-z0-9.!#$%&'*/=?^_`{|}~+-]"
  Domain = "[A-Za-z0-9._-]"
  AtSign = InStr(S, "@")
  If AtSign < 2 Then Exit Function
  If Not Mid(S, AtSign - 1, 1) Like Locale Then Exit Function
  For X = AtSign To 1 Step -1
    If Not Mid(" " & S, X, 1) Like Locale Then
      S = Mid(S, X)
      If Left(S, 1) = "." Then S = Mid(S, 2)
      Exit For
    End If
  Next
  AtSign = InStr(S, "@")
  For X = AtSign + 1 To Len(S) + 1
    If Not Mid(S & " ", X, 1) Like Domain Then
      S = Left(S, X - 1)
      If Right(S, 1) = "." Then S = Left(S, Len(S) - 1)
      GetEmailAddress = S
      Exit For
    End If
  Next
End Function[/td]
[/tr]
[/table]

 

[Ingolf]

Now is perfect. Thank you.

 

[Rick Rothstein]

Now is perfect. Thank you.

You are quite welcome... I am glad we were able to work everything out. By the way, the GetEmailAddress function (which is quite robust) can be used as a UDF in addition to being able to be called by other VB code. The first argument is the text string to look for the email address in and there is a second optional argument that allows you to start the search somewhere other than at the beginning of the text (in case you want to retrieve the second email address)... best for this second argument would be to search for the @ symbol, add one to it and use that as the second argument (in order to retrieve the next email address).