Separating Emails

[zinah]

Hi,

I have below that have "email / name". Is there any way that I can remove the names and the extra space below each email and keep only emails?

Email/Name	Expected Results
a@abc.com / A b@abc.com / B	a@abc.com b@abc.com
a@abc.com / A f@abc.com / F	a@abc.com f@abc.com
d@abc.com / D e@abc.com / E f@abc.com / F
d@abc.com / D e@abc.com / E g@abc.com / G a@abc.com / A

 

[Peter_SSs]

If you did want to try a formula approach (not limited to 4 emails), you could try this based on your sample data.

zinah.xlsm
	A	B
1	Email/Name	Results
2	a@abc.com / A b@abc.com / B	a@abc.com b@abc.com
3	a@abc.com / A f@abc.com / F	a@abc.com f@abc.com
4	d@abc.com / D e@abc.com / E f@abc.com / F	d@abc.com e@abc.com f@abc.com
5	d@abc.com / D e@abc.com / E g@abc.com / G a@abc.com / A	d@abc.com e@abc.com g@abc.com a@abc.com
Sheet4

Cell Formulas
Range	Formula
B2:B5	B2	=TEXTJOIN(CHAR(10),1,TRIM(LEFT(SUBSTITUTE(FILTERXML("<p><c>"&SUBSTITUTE(A2,CHAR(10)&CHAR(10),"</c><c>")&"</c></p>","//c")," ",REPT(" ",100)),100)))

 

[zinah]

Try this version. It is just the 'Pattern' line that has changed.

Sub ExtractEmails()
  Dim RX As Object
  Dim a As Variant, b As Variant
  Dim i As Long
 
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.Pattern = " [^@]+( |" & vbLf & "|$)"
  a = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a)
    b(i, 1) = Replace(RTrim(RX.Replace(a(i, 1), " ")), " ", vbLf)
  Next i
  Range("B2").Resize(UBound(b)).Value = b
End Sub

Thank you so much, the macro worked perfectly great. I really appreciate your kind help!

 

[zinah]

If you did want to try a formula approach (not limited to 4 emails), you could try this based on your sample data.

zinah.xlsm
	A	B
1	Email/Name	Results
2	a@abc.com / A b@abc.com / B	a@abc.com b@abc.com
3	a@abc.com / A f@abc.com / F	a@abc.com f@abc.com
4	d@abc.com / D e@abc.com / E f@abc.com / F	d@abc.com e@abc.com f@abc.com
5	d@abc.com / D e@abc.com / E g@abc.com / G a@abc.com / A	d@abc.com e@abc.com g@abc.com a@abc.com
Sheet4

Cell Formulas
Range	Formula
B2:B5	B2	=TEXTJOIN(CHAR(10),1,TRIM(LEFT(SUBSTITUTE(FILTERXML("<p><c>"&SUBSTITUTE(A2,CHAR(10)&CHAR(10),"</c><c>")&"</c></p>","//c")," ",REPT(" ",100)),100)))

That's really kind of you! I loved the formula and it worked too

 

[Peter_SSs]

You're welcome. Glad they both worked for you.