Microsoft Office Forums - View Single Post - [Solved] need to extract email addresses from excel files

Catalin.B · 06-07-2013, 07:57 AM

Try this code, it will check every word ; if the word contains "@", then that word is sent for email validation function; if it passes validation, then the email address is sent to the next column cell:

Code:

Option Explicit
Sub ExtractMail()
Dim Result As Boolean
Dim i As Integer, j As Integer
Dim LastRow As Long
Dim TextString As Variant
Dim Words As String
LastRow = ActiveSheet.Cells(1, "D").End(xlDown).Row
    For i = 1 To LastRow
         TextString = Split(ActiveSheet.Cells(i, "D"), " ")
            For j = 0 To UBound(TextString)
                Words = TextString(j)
                    If InStr(1, Words, "@") > 0 Then
                        Result = ValidareAdresaEmail(Words)
                            If Result Then
                                ActiveSheet.Cells(i, "E") = Words
                             End If
                     End If
             Next j
    Next i
    
End Sub
Function ValidareAdresaEmail(ByVal AdresaEmail As String) As Boolean
    Dim objRegEx As Object
    On Error GoTo Fin
    Set objRegEx = CreateObject("Vbscript.Regexp")
    With objRegEx
        .Pattern = "[a-z0-9!#$%&'*+/=?^_`{|}~-]+(?:\.[a-z0-9!" & _
                        "#$%&'*+/=?^_`{|}~-]+)*@(?:[a-z0-9](?:" & _
                        "[a-z0-9-]*[a-z0-9])?\.)+[a-z0-9](?:" & _
                        "[a-z0-9-]*[a-z0-9])?"

        .IgnoreCase = True
        ValidareAdresaEmail = .Test(AdresaEmail)
    End With
Fin:
    Set objRegEx = Nothing
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Function