Solved

Excel VBA Data Validation for Email Addresses

Posted on 2007-03-22
8
858 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
 

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
Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

 
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

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

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

Suggested Solutions

This article describes some techniques which will make your VBA or Visual Basic Classic code easier to understand and maintain, whether by you, your replacement, or another Experts-Exchange expert.
You can of course define an array to hold data that is of a particular type like an array of Strings to hold customer names or an array of Doubles to hold customer sales, but what do you do if you want to coordinate that data? This article describes…
This Micro Tutorial demonstrate the bugs in Microsoft Excel for Mac with Pivot Charts.
This Micro Tutorial demonstrates using Microsoft Excel pivot tables, how to reverse engineer competitors' marketing strategies through backlinks.

864 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

Need Help in Real-Time?

Connect with top rated Experts

24 Experts available now in Live!

Get 1:1 Help Now