Including separator in VBA code to extract email addresses from a string

[K_TF_2015]

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

[#2]

@K_TF_2015 

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) & getStr

With this line of code:

Vba code:

outStr = outStr & "; " & getStr

This 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 Sub

With 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.

[#3]

Thank you so much @NikolinoDE, that worked perfectly! Much appreciated!

[#4]

I am glad that this helped you.
Furthermore, I wish you much success with Excel!