Solved

Excel VBA Data Validation for Email Addresses

Posted on 2007-03-22
8
886 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 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
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 

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

Creating Instructional Tutorials  

For Any Use & On Any Platform

Contextual Guidance at the moment of need helps your employees/users adopt software o& achieve even the most complex tasks instantly. Boost knowledge retention, software adoption & employee engagement with easy solution.

Question has a verified solution.

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

If you need to start windows update installation remotely or as a scheduled task you will find this very helpful.
Excel can be a tricky bit of software to get your head around. Whilst you’ll be able to eventually get to grips with the basic understanding of how to get by, there are a few Excel tips that not everybody will even know about let alone know how to d…
This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

623 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