Split Phone and Email

[austinandreikurt]

Hi,

How do I split phone and email address merge in a cell? Below are the examples and the needed results:

• There are instances where there is no phone or no email or there is 2 or more emails.
• The phone is always one time only if there is and the result should replace characters () and -
• The email is always with "@" and there might be 2 or more emails, the result should have a separator ;
• There are extra spaces to be eliminated with TRIM/CLEAN

Phone / Email	REMARKS	Phone Result	Email Result
(925) 474-1000 abcdefghij@yahoo.org	Usual sample	9254741000​	abcdefghij@yahoo.org
(925) 828-1000 a2z@google.com	Usual sample	9258281000​	a2z@google.com
yesyes@outlook.org	Email Only		yesyes@outlook.org
(925) 828-1000 a2z@google.com abcdefghij@yahoo.org	2 emails	9258281000​	a2z@google.com; abcdefghij@yahoo.org
(925) 800-1000 hithere@yahoo.com	Usual sample	9258001000​	hithere@yahoo.com

Thank you in advance!

 

[lrobbo314]

How about this?

Austin
	A	B	C	D
1	Phone / Email	REMARKS	Phone Result	Email Result
2	(925) 474-1000 abcdefghij@yahoo.org	Usual sample	(925) 474-1000	abcdefghij@yahoo.org
3	(925) 828-1000 a2z@google.com	Usual sample	(925) 828-1000	a2z@google.com
4	yesyes@outlook.org	Email Only		yesyes@outlook.org
5	(925) 828-1000 a2z@google.com abcdefghij@yahoo.org	2 emails	(925) 828-1000	a2z@google.com;abcdefghij@yahoo.org
6	(925) 800-1000 hithere@yahoo.com	Usual sample	(925) 800-1000	hithere@yahoo.com
Sheet5

Cell Formulas
Range	Formula
C2:C6	C2	=IFERROR(LEFT(A2,SEARCH(" ",A2,SEARCH(" ",A2)+1)),"")
D2:D6	D2	=SUBSTITUTE(SUBSTITUTE(A2,C2,"")," ",";")

 

[austinandreikurt]

@lrobbo314 Thanks for the quick response. The formula with Column C won't work as the " " has a different " " character from raw data. Also, there might be instances too the the phone number might not have "()". It won't be too consistent for phones. It can be 10 - 16 characters due to added spaces, parenthesis and hypen, but it will always need to pick the 10 digit phone number.

 

[lrobbo314]

Does this work?

austin
	A	B	C	D
1	Phone / Email	REMARKS	Phone Result	Email Result
2	(925) 474-1000 abcdefghij@yahoo.org	Usual sample	(925) 474-1000	abcdefghij@yahoo.org
3	(925) 828-1000 a2z@google.com	Usual sample	(925) 828-1000	a2z@google.com
4	yesyes@outlook.org	Email Only		yesyes@outlook.org
5	(925) 828-1000 a2z@google.com abcdefghij@yahoo.org	2 emails	(925) 828-1000	a2z@google.com;abcdefghij@yahoo.org
6	(925) 800-1000 hithere@yahoo.com	Usual sample	(925) 800-1000	hithere@yahoo.com
Sheet7

Cell Formulas
Range	Formula
C2:C6	C2	=IFERROR(LEFT(A2,FIND(CHAR(160),A2)),"")
D2:D6	D2	=SUBSTITUTE(SUBSTITUTE(A2,C2,""),CHAR(160),";")

 

[austinandreikurt]

@lrobbo314 I am not really sure how consistent the " " character will be once paste in excel from our intranet. For now the CHAR(160) works but would it possible to make it error proof? Say an example will be "9254741000 abcdefghij@yahoo.org" where the " " will really be space char. The formula above will no longer work. Also please, will need a formula in Column E to clean the phone numbers. Will only need the 10digits, no (), no spaces, no dash and other characters except for the numbers.

 

[lrobbo314]

Going to need to switch to VBA on this one.

austin
	A	B	C	D
1	Phone / Email	REMARKS	Phone Result	Email Result
2	(925) 474-1000 abcdefghij@yahoo.org	Usual sample	(925) 474-1000	abcdefghij@yahoo.org
3	(925) 828-1000 a2z@google.com	Usual sample	(925) 828-1000	a2z@google.com
4	yesyes@outlook.org	Email Only		yesyes@outlook.org
5	(925) 828-1000 a2z@google.com abcdefghij@yahoo.org	2 emails	(925) 828-1000	a2z@google.comabcdefghij@yahoo.org
6	(925) 800-1000 hithere@yahoo.com	Usual sample	(925) 800-1000	hithere@yahoo.com
7	9254741000 test.gmail.com	Another Sample	9254741000	test.gmail.com
Sheet7

Cell Formulas
Range	Formula
C2:C7	C2	=IFERROR(Phone(A2),"")
D2:D7	D2	=SUBSTITUTE(SUBSTITUTE(TRIM(SUBSTITUTE(A2,C2,""))," ",";"),CHAR(160),"")

Here is the code for the VBA function 'Phone'...

Function Phone(s As String)
With CreateObject("VBScript.RegExp")
    .Pattern = "\(?\d{3}\)?\s?\d{3}\-?\d{4}"
    Phone = .Execute(s)(0)
End With
End Function

 

[lrobbo314]

Missed the part that you wanted to clean the phone numbers as well.

Austin
	A	B	C	D
1	Phone / Email	REMARKS	Phone Result	Email Result
2	(925) 474-1000 abcdefghij@yahoo.org	Usual sample	9254741000	(925);474-1000abcdefghij@yahoo.org
3	(925) 828-1000 a2z@google.com	Usual sample	9258281000	(925);828-1000a2z@google.com
4	yesyes@outlook.org	Email Only		yesyes@outlook.org
5	(925) 828-1000 a2z@google.com abcdefghij@yahoo.org	2 emails	9258281000	(925);828-1000a2z@google.comabcdefghij@yahoo.org
6	(925) 800-1000 hithere@yahoo.com	Usual sample	9258001000	(925);800-1000hithere@yahoo.com
7	9254741000 test.gmail.com	Another Sample	9254741000	test.gmail.com
Sheet7

Cell Formulas
Range	Formula
C2:C7	C2	=IFERROR(Phone(A2),"")
D2:D7	D2	=SUBSTITUTE(SUBSTITUTE(TRIM(SUBSTITUTE(A2,C2,""))," ",";"),CHAR(160),"")

Function Phone(s As String)
With CreateObject("VBScript.RegExp")
    .Pattern = "\(?\d{3}\)?\s?\d{3}\-?\d{4}"
    Phone = xClean(.Execute(s)(0))
End With
End Function

Function xClean(s As Variant)
Dim chrs As Variant:    chrs = Array("(", ")", "-", " ", Chr(160))

For i = LBound(chrs) To UBound(chrs)
    s = Replace(s, chrs(i), "")
Next i
xClean = s
End Function

 

[austinandreikurt]

@lrobbo314 I have used the first Phone Function as the second with the combined xClean and Phone will overwrite what was in Column D so I just used an xClean function separately in Column E the substitute formula to work just fine. Then I change the formula in D2 to =SUBSTITUTE(SUBSTITUTE(TRIM(SUBSTITUTE(A2,C2,"")),CHAR(160),"",1),CHAR(160),"; "). Now it works perfectly fine. Thank you!

 

[lrobbo314]

If you'd rather. I changed the code to run as a subroutine instead of using functions.

Just run 'PHONEX' and it should turn this...

Book1
	A	B	C	D
1	Phone / Email	REMARKS	Phone Result	Email Result
2	(925) 474-1000 abcdefghij@yahoo.org	Usual sample
3	(925) 828-1000 a2z@google.com	Usual sample
4	yesyes@outlook.org	Email Only
5	(925) 828-1000 a2z@google.com abcdefghij@yahoo.org	2 emails
6	(925) 800-1000 hithere@yahoo.com	Usual sample
7	9254741000 test.gmail.com	Another Sample
Sheet1

into this...

Book1
	A	B	C	D
1	Phone / Email	REMARKS	Phone Result	Email Result
2	(925) 474-1000 abcdefghij@yahoo.org	Usual sample	9254741000	abcdefghij@yahoo.org
3	(925) 828-1000 a2z@google.com	Usual sample	9258281000	a2z@google.com
4	yesyes@outlook.org	Email Only		yesyes@outlook.org
5	(925) 828-1000 a2z@google.com abcdefghij@yahoo.org	2 emails	9258281000	a2z@google.com;abcdefghij@yahoo.org
6	(925) 800-1000 hithere@yahoo.com	Usual sample	9258001000	hithere@yahoo.com
7	9254741000 test.gmail.com	Another Sample	9254741000	test.gmail.com
Sheet1

Function Phone(s As Variant)
On Error GoTo ERH

With CreateObject("VBScript.RegExp")
    .Pattern = "\(?\d{3}\)?\s?\d{3}\-?\d{4}"
    Phone = .Execute(s)(0)
End With
Exit Function
ERH:
If Err.Number = 5 Then
    Resume Next
Else
    MsgBox "Error#" & Err.Number & vbLf & Err.Description
End If
End Function

Function xClean(s As Variant)
Dim chrs As Variant:    chrs = Array("(", ")", "-", " ", Chr(160))

For i = LBound(chrs) To UBound(chrs)
    s = Replace(s, chrs(i), "")
Next i
xClean = s
End Function

Function CHL(s As Variant) As String
Dim cd As Integer:  cd = Asc(Left(s, 1))
Debug.Print cd
If cd = 32 Or cd = 160 Then
    CHL = Right(s, Len(s) - 1)
Else
    CHL = s
End If
End Function

Sub PHONEX()
Dim r As Range:         Set r = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
Dim AR() As Variant:    AR = r.Value2
Dim RES() As Variant:   ReDim RES(1 To UBound(AR), 1 To 2)
Dim p As String, e As String

For i = 1 To UBound(AR)
    p = Phone(AR(i, 1))
    e = Replace(AR(i, 1), p, "")
    RES(i, 1) = xClean(p)
    RES(i, 2) = Replace(Replace(CHL(e), Chr(160), ";"), " ", ";")
Next i

r.Offset(, 2).Resize(r.Rows.Count, 2).Value = RES
End Sub