Solved

Excel VBA Data Validation for Email Addresses

Posted on 2007-03-22
8
852 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
Comment Utility
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
Comment Utility
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
Comment Utility
Can you give me an example of one that works when it shouldn't?
0
 

Author Comment

by:bfreescott
Comment Utility
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
How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

 
LVL 85

Expert Comment

by:Rory Archibald
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
That worked!  It's always the slightest adjustment.  Thanks again!
0

Featured Post

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

When trying to find the cause of a problem in VBA or VB6 it's often valuable to know what procedures were executed prior to the error. You can use the Call Stack for that but it is often inadequate because it may show procedures you aren't intereste…
This article will guide you to convert a grid from a picture into Excel format using Microsoft OneNote and no other 3rd party application.
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.

743 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

8 Experts available now in Live!

Get 1:1 Help Now