CODEWITHSUNDEEP
excelexcel-formulavba
Courtez
Courtez

Reputation: 11

Excel: Separate Extracted emails with a space

I'm using an excel macro to pull emails from longer strings (i.e. 'the email [email protected] will be extracted' - would return only '[email protected]'), the only problem is if there are two emails in the string it will return them as one large string that looks like this: '[email protected]@email.com'. What I would like is for it to return it as this: '[email protected] [email protected]'. I'll provide the function I'm using to do this and was hoping someone would know how to modify it in it's current state to make it so it separates the emails by space.

Function ExtractEmailFun(extractStr As String) As String
'Update 20130829
Dim CharList As String
On Error Resume Next
CheckStr = "[A-Za-z0-9._-]"
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 & Mid(extractStr, p, 1)
            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
ExtractEmailFun = OutStr
End Function

Thanks in advance!

Upvotes: 1

Views: 89

Answers (2)

David Zemens
David Zemens

Reputation: 53623

Seems like this could be much more efficiently done. I agree with @nbayly Split on space character, iterate the array of "words" and if the "word" contains an @ then you can safely assume it's an email address.

Function GetEmails(words$)

Dim word
Dim emails As Object
Set emails = CreateObject("Scripting.Dictionary")

For Each word In Split(words, " ")
    'Strip characters that you don't like:
    word = Replace(word, "'", "")
    word = Replace(word, ",", "")
    word = Replace(word, ")", "")
    word = Replace(word, "(", "")
    'etc...
    word = Trim(word)
    'Get rid of trailing periods
    word = IIf(Right(word, 1) = ".", Left(word, Len(word) - 1), word)
    If InStr(1, word, "@") <> 0 Then
        'This is probably an email address
        ' adds to the dictionary
        emails(word) = word
    Else
        'This is not an email address, do nothing
    End If
Next

GetEmails = Join(emails.Keys(), " ")

End Function

Upvotes: 0

YowE3K
YowE3K

Reputation: 23974

If you wish to replace the line feed character from the current output string, which looks like

[email protected]
[email protected]

with a space, so that it looks like

[email protected] [email protected]

you can simply change

OutStr = OutStr & Chr(10) & getStr

to be

OutStr = OutStr & " " & getStr

Upvotes: 1

Related Questions