Excel VBA Data Validation for Email Addresses

Hi Scott,
Try these:

Function IsValidEmail(value As String, Optional strOut As String) As Boolean
'
    Dim RE As Object, match
    Set RE = CreateObject("vbscript.RegExp")
   
        RE.Pattern = "[a-zA-Z0-9\._-]+@([a-zA-Z0-9_-]+\.)+([a-zA-Z]{2,3})$"
        If RE.test(value) Then
            If Not IsMissing(strOut) Then
                Set match = RE.Execute(value)
                If match.Count Then strOut = match(0)
            End If
            IsValidEmail = True
        Else
            IsValidEmail = False
            strOut = ""
        End If
    Set RE = Nothing
'
End Function
Function GetAddress(value As String)
    Dim strOut As String
    If IsValidEmail(value, strOut) Then
        GetAddress = strOut
    Else
        GetAddress = ""
    End If
End Function


HTH
Rory

Hi Rory,

Thanks for the response.  I was excited to see the functions you posted, but when implemented, they return every string, regardless of whether it is an email addresss or not.  What am I missing?

-S

Can you give me an example of one that works when it shouldn't?

Here are some examples of the strings being returned (I'm not using real names, numbers, or addresses obviously, but the rest is exactly what GetAddress returns.

Bob Smith @ 888-555-1212
Bob Smith @ mycompany is working on the problem.
Bob Smith
Bob Smith 888-555-1212
Bob is driving me crazy.
No more Bob.

Whatever the cells contains is being returned.
Every row is accounted for, so nothing is being excluded in the validation process.

Thanks again Rory!

Scott,
None of those returns anything for me. Are you sure you copied the code correctly and that you don't have any other versions of the functions somewhere?
Regards,
Rory
PS How are you actually using them?

Rory - thanks again for your help; I'm upping the point value on this for making you analyze my lengthy proc below.  I've commented out the lines I had in place that used just the IsValidEmail call.  This is how I am using the two functions you provided.  Let me know if I made a mistake implementing them or if you see other inefficiencies in my code.  Thanks again!

Function IsValidEmail(value As String, Optional strOut As String) As Boolean
'
    Dim RE As Object, match
    Set RE = CreateObject("vbscript.RegExp")
   
        RE.Pattern = "[a-zA-Z0-9\._-]+@([a-zA-Z0-9_-]+\.)+([a-zA-Z]{2,3})$"
        If RE.test(value) Then
            If Not IsMissing(strOut) Then
                Set match = RE.Execute(value)
                If match.Count Then strOut = match(0)
            End If
            IsValidEmail = True
        Else
            IsValidEmail = False
            strOut = ""
        End If
    Set RE = Nothing
'
End Function
Function GetAddress(value As String)
    Dim strOut As String
    If IsValidEmail(value, strOut) Then
        GetAddress = strOut
    Else
        GetAddress = ""
    End If
End Function
Sub Copy_Rep_Email_Addresses()
'
    UserForm100.Show
    UserForm100.TextBox100.Width = 0
    UserForm100.TextBox100.BackColor = vbBlue
   
    Application.Cursor = xlWait
    Application.StatusBar = "Adding Rep Email Addresses..."
    Application.ScreenUpdating = False
   
    Dim rng As Range
    Dim c As Range
    Dim r As Integer
    Dim X As Single
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim i As Integer
    Dim value As String
       
    Set ws1 = Sheets("COBY")
    Set ws2 = Sheets("All_Leads")
    i = 0
           
    r = ws1.Cells(Rows.Count, "A").End(xlUp).Row
    Set rng = ws1.Range("A2:A" & r)
    X = 262.5 / r
   
    Application.Goto Reference:=Worksheets("All_Leads").Range("A7")
   
    For Each c In rng
    value = c.Offset(0, 1).value
   
        'If IsValidEmail(value) Then
        GetAddress value
           
            With ws2
            .Range("A7").Select

                Do
               
                    If ActiveCell.value = c.value Then
                        'ActiveCell.Offset(0, 12).value = c.Offset(0, 1).value
                        ActiveCell.Offset(0, 12).value = value
                    Else

                    End If
                   
                    ActiveCell.Offset(1, 0).Select
                   
                Loop Until IsEmpty(ActiveCell.Offset(0, 0))
   
            End With

        DoEvents
       
        i = i + 1
       
        UserForm100.TextBox100.Width = i * X
        UserForm100.Label100 = Str(CByte((i / r) * 100)) & "%"
       
        'Else 'Add code here to do something with invalid email addresses
       
        'End If
       
    Next c
   
    UserForm100.Hide
   
    Application.StatusBar = "Finalizing Email Addresses..."
    Review_Rep_Addresses
   
    Application.Goto Reference:=Worksheets("Macros").Range("A2")
    Application.ScreenUpdating = True
    Application.StatusBar = False
    Application.Cursor = xlDefault
'
End Sub

That worked!  It's always the slightest adjustment.  Thanks again!