Cleaning up contact information

[Woodsa]

Hi all,

I have a column of contact information where it should just be one phone number, but it has been populated with multiple phone numbers, emails and various characters.

I have tried removing all characters and only taking the first 11 numerical values, but in some instances the column may have contained two phone numbers with the first number having the incorrect number of digits meaning I have taken the numbers from number 1 & number 2.

I am trying to split the numbers and emails exactly how they were entered (even if incorrect), that way I can perform validation on the numbers and clear any that fail validation. I'd also like to remove and +44 and replace with 0 etc..

Please see mock data below to show what I am trying to do.

Original Data	Desired Result 1 (tel 1)	Desired Result 2 (tel 2)	Desired Result 3 (email 1)	Desired Result 4 (email 2)
Phone: 02356 898/Mob: 07856498556	02356898	07856498556
02365898756 / Email example@email.com	02365898756		example@email.com
other@email.com 077854698563	077854698563		other@email.com
023659987585 mremail@email.com/mrsemail@email.co.uk	023659987585		mremail@email.com	mrsemail@email.co.co.uk
+44(0)1365985678	01365985678

Can anyone help with a way to achieve this?

 

[Peter_SSs]

This sort of task can be quite tricky, particularly checking for valid email addresses. However, I think this should get you a reasonable way along the track. It will extract at most 2 of each type.

Sub Phone_Email()
  Dim RX As Object, M As Object
  Dim a As Variant, b As Variant
  Dim i As Long, c As Long
  
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  a = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 4)
  
  'Phone
  RX.Pattern = "(\(\d+\))?\d[\d ]{6,}"
  For i = 1 To UBound(a)
    c = 0
    For Each M In RX.Execute(a(i, 1))
      c = c + 1
      b(i, c) = Replace(Replace(Replace(M, " ", ""), "(", ""), ")", "")
      If c = 2 Then Exit For
    Next M
  Next i
  
  'Email
  RX.Pattern = "[A-Za-z0-9._\-]+@[A-Za-z0-9._\-]+"
  For i = 1 To UBound(a)
    c = 0
    For Each M In RX.Execute(a(i, 1))
      c = c + 1
      b(i, c + 2) = M
      If c = 2 Then Exit For
    Next M
  Next i
  
  'Results
  With Range("B2").Resize(UBound(b, 1), UBound(b, 2))
    .NumberFormat = "@"
    .Value = b
  End With
End Sub

My sample data and results:

Woodsa.xlsm
	A	B	C	D	E
1	Original Data	Desired Result 1 (tel 1)	Desired Result 2 (tel 2)	Desired Result 3 (email 1)	Desired Result 4 (email 2)
2	Phone: 02356 898/Mob: 07856498556	02356898	07856498556
3	02365898756 / Email example@email.com	02365898756		example@email.com
4	other@email.com 077854698563	077854698563		other@email.com
5	023659987585 mremail@email.com/mrsemail@email.co.uk	023659987585		mremail@email.com	mrsemail@email.co.uk
6	+44(0)1365985678	01365985678
7	22222222 xvxzv 65656565dgfdg9898989865 abc@abc.com/abc1@abc.com/abc2@abc.com	22222222	65656565	abc@abc.com	abc1@abc.com
Sheet1

 

[Woodsa]

This sort of task can be quite tricky, particularly checking for valid email addresses. However, I think this should get you a reasonable way along the track. It will extract at most 2 of each type.

Sub Phone_Email()
  Dim RX As Object, M As Object
  Dim a As Variant, b As Variant
  Dim i As Long, c As Long
 
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  a = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 4)
 
  'Phone
  RX.Pattern = "(\(\d+\))?\d[\d ]{6,}"
  For i = 1 To UBound(a)
    c = 0
    For Each M In RX.Execute(a(i, 1))
      c = c + 1
      b(i, c) = Replace(Replace(Replace(M, " ", ""), "(", ""), ")", "")
      If c = 2 Then Exit For
    Next M
  Next i
 
  'Email
  RX.Pattern = "[A-Za-z0-9._\-]+@[A-Za-z0-9._\-]+"
  For i = 1 To UBound(a)
    c = 0
    For Each M In RX.Execute(a(i, 1))
      c = c + 1
      b(i, c + 2) = M
      If c = 2 Then Exit For
    Next M
  Next i
 
  'Results
  With Range("B2").Resize(UBound(b, 1), UBound(b, 2))
    .NumberFormat = "@"
    .Value = b
  End With
End Sub

My sample data and results:

Woodsa.xlsm
	A	B	C	D	E
1	Original Data	Desired Result 1 (tel 1)	Desired Result 2 (tel 2)	Desired Result 3 (email 1)	Desired Result 4 (email 2)
2	Phone: 02356 898/Mob: 07856498556	02356898	07856498556
3	02365898756 / Email example@email.com	02365898756		example@email.com
4	other@email.com 077854698563	077854698563		other@email.com
5	023659987585 mremail@email.com/mrsemail@email.co.uk	023659987585		mremail@email.com	mrsemail@email.co.uk
6	+44(0)1365985678	01365985678
7	22222222 xvxzv 65656565dgfdg9898989865 abc@abc.com/abc1@abc.com/abc2@abc.com	22222222	65656565	abc@abc.com	abc1@abc.com
Sheet1

This is great, thank you!

 

[Peter_SSs]

You're welcome. Thanks for the follow-up.