VBA - If Cell Contains Email address

[karan2211]

Hi There,

I want to get a VBA code for checking if a particular cells has got any email address

Suppose Cell A1 = abc then it should give error "Please enter a valid email address"

and If Cell A1 = abc@xyz then it should let the user enter that value as it is a valid email address

VBA code can look for @ in the cell value if @ sign is not present a msgbox will appear.

Any help will be much appreciated.

Thanks!

 

[Chris Mack]

Do you want this MsgBox to appear when you've made an attempt at typing the email address in? Or is it a button click to check the whole column? Etc.

 

[karan2211]

Do you want this MsgBox to appear when you've made an attempt at typing the email address in? Or is it a button click to check the whole column? Etc.

Hi Chris,

Thanks for your reply.

I want the msgbox to appear after the attempt has been made.

 

[Chris Mack]

Hi

This is what I've got so far, assuming you'll be putting the email address in column B (i.e. column 2, as per the code), put this code in the 'ThisWorkbook' object:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Target.Column = 2 And Target.Value <> "" And Evaluate("COUNTIF(" & Target.Address & ",""*@*.*"")") <> 1 Then
        Target.ClearContents
        Target.Activate
        MsgBox "Please enter a valid email address."
    End If
End Sub

I've put another qualifier in for a full stop (period) (I'm not sure it's a requirement of an email address but I'm pretty sure it is, anyway you can see from the code I'm testing for the format "*@*.*", where * is a wildcard).

Let me know if this is appropriate.

Hope this helps,

Chris.

 

[karan2211]

Hi Chris,

The email address needs to be entered in a merged cell E7:H7 and I tried changing the Target.Column = 5 as per E Column and pasted the Macro in This Workbook but it was not working. Am I doing something wrong?

Thanks in advance for helping me.

 

[Chris Mack]

This should work:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    cell = Left(Range(Target, Target.Offset(0, 2)).Address, InStr(Range(Target, Target.Offset(0, 2)).Address, ":") - 1)
    If Range(cell).Column = 5 And Range(cell).Value <> "" And Evaluate("COUNTIF(" & Range(cell).Address & ",""*@*.*"")") <> 1 Then
        Range(Target, Target.Offset(0, 3)).ClearContents
        Target.Activate
        MsgBox "Please enter a valid email address."
    End If
End Sub

Hope this helps,

Chris.