Solved

Excel VBA Data Validation for Email Addresses

Posted on 2007-03-22
8
868 Views
Last Modified: 2012-06-27
This is the function I am successfully using to validate fields containing email addresses.

Function IsValidEmail(value As String) As Boolean
'
    Dim RE As Object
    Set RE = CreateObject("vbscript.RegExp")
   
        RE.Pattern = "^[a-zA-Z0-9\._-]+@([a-zA-Z0-9_-]+\.)+([a-zA-Z]{2,3})$"
        IsValidEmail = RE.Test(value)
   
    Set RE = Nothing
'
End Function

While it works great for identifying cells with email addresses, some records have a combination of data in them which include, among other extraneous information, email addresses.

For example:
A1:A3 may look like this:

user@domain.com
212-555-1212
My email address is user@domain.com.

My current function validates A1 and nothing else, even though A3 does contain a valid email address.
I need help not only to validate fields, like A3, that contain a valid email address, but to then extract the valid address from that field.

Thanks in advance!

Scott


0
Comment
Question by:bfreescott
  • 4
  • 4
8 Comments
 
LVL 85

Expert Comment

by:Rory Archibald
ID: 18771303
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
0
 

Author Comment

by:bfreescott
ID: 18773780
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
0
 
LVL 85

Expert Comment

by:Rory Archibald
ID: 18773931
Can you give me an example of one that works when it shouldn't?
0
Free Tool: Postgres Monitoring System

A PHP and Perl based system to collect and display usage statistics from PostgreSQL databases.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

 

Author Comment

by:bfreescott
ID: 18774086
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!
0
 
LVL 85

Expert Comment

by:Rory Archibald
ID: 18778234
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?
0
 

Author Comment

by:bfreescott
ID: 18778955
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
0
 
LVL 85

Accepted Solution

by:
Rory Archibald earned 500 total points
ID: 18779062
You are not actually doing anything with the return value of the getaddress function - change this:
        GetAddress value

to this:

        value = GetAddress(value)

you may also want to add a check to see if Len(value) > 0 after performing the function on it.

HTH
Rory
0
 

Author Comment

by:bfreescott
ID: 18779312
That worked!  It's always the slightest adjustment.  Thanks again!
0

Featured Post

Free Tool: Path Explorer

An intuitive utility to help find the CSS path to UI elements on a webpage. These paths are used frequently in a variety of front-end development and QA automation tasks.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Workbook link problems after copying tabs to a new workbook? David Miller (dlmille) Intro Have you either copied sheets to a new workbook, and after having saved and opened that workbook, you find that there are links back to the original sou…
Since upgrading to Office 2013 or higher installing the Smart Indenter addin will fail. This article will explain how to install it so it will work regardless of the Office version installed.
This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.
Although Jacob Bernoulli (1654-1705) has been credited as the creator of "Binomial Distribution Table", Gottfried Leibniz (1646-1716) did his dissertation on the subject in 1666; Leibniz you may recall is the co-inventor of "Calculus" and beat Isaac…

830 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question