Forum Discussion
Including separator in VBA code to extract email addresses from a string
Hi,
I have found some VBA code to extract multiple email addresses from a text string in excel, which works brilliantly, however, it combines the email addresses into one string. I'd like to amend the code so that it separates out the email addresses, ideally with a semi-colon(;) followed by a space, but I'm not sure how to do this, so if anyone is able to offer any help that would be much appreciated, thank you!
The VBA code I have found is below:
Sub ExtractEmail()
'Update 20130829
Dim WorkRng As Range
Dim arr As Variant
Dim CharList As String
On Error Resume Next
xTitleId = "KutoolsforExcel"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
arr = WorkRng.Value
CheckStr = "[A-Za-z0-9._-]"
For i = 1 To UBound(arr, 1)
For j = 1 To UBound(arr, 2)
extractStr = arr(i, j)
outStr = ""
Index = 1
Do While True
Index1 = VBA.InStr(Index, extractStr, "@")
getStr = ""
If Index1 > 0 Then
For p = Index1 - 1 To 1 Step -1
If Mid(extractStr, p, 1) Like CheckStr Then
getStr = Mid(extractStr, p, 1) & getStr
Else
Exit For
End If
Next
getStr = getStr & "@"
For p = Index1 + 1 To Len(extractStr)
If Mid(extractStr, p, 1) Like CheckStr Then
getStr = getStr & "; "
Else
Exit For
End If
Next
Index = Index1 + 1
If outStr = "" Then
outStr = getStr
Else
outStr = outStr & Chr(10) & getStr
End If
Else
Exit Do
End If
Loop
arr(i, j) = outStr
Next
Next
WorkRng.Value = arr
End Sub
To modify the VBA code so that the extracted email addresses are separated by a semi-colon (;) followed by a space, you can make the following changes:
Replace this line of code:
Vba code:
outStr = outStr & Chr(10) & getStrWith this line of code:
Vba code:
outStr = outStr & "; " & getStrThis will append the extracted email address to the outStr variable, separated by a semi-colon and a space.
The updated VBA code will look like this (untested):
Sub ExtractEmail() ' Update 20130829 Dim WorkRng As Range Dim arr As Variant Dim CharList As String On Error Resume Next xTitleId = "KutoolsforExcel" Set WorkRng = Application.Selection Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8) arr = WorkRng.Value CheckStr = "[A-Za-z0-9._-]" For i = 1 To UBound(arr, 1) For j = 1 To UBound(arr, 2) extractStr = arr(i, j) outStr = "" Index = 1 Do While True Index1 = VBA.InStr(Index, extractStr, "@") getStr = "" If Index1 > 0 Then For p = Index1 - 1 To 1 Step -1 If Mid(extractStr, p, 1) Like CheckStr Then getStr = Mid(extractStr, p, 1) & getStr Else Exit For End If Next getStr = getStr & "@" For p = Index1 + 1 To Len(extractStr) If Mid(extractStr, p, 1) Like CheckStr Then getStr = getStr & "; " Else Exit For End If Next Index = Index1 + 1 If outStr = "" Then outStr = getStr Else outStr = outStr & "; " & getStr End If Else Exit Do End If Loop arr(i, j) = outStr Next Next WorkRng.Value = arr End SubWith this modification, the email addresses will be extracted and separated by semi-colons in the outStr variable, and then the modified values will be written back to the cells in the specified range (WorkRng).
My answers are voluntary and without guarantee!
Hope this will help you.
- Thank you so much NikolinoDE, that worked perfectly! Much appreciated!
- I am glad that this helped you.
Furthermore, I wish you much success with Excel!
