Delete invalid email address in range

[lricher]

Hello Gurus,

Courtesy of Paelo at VBA Express i have found a VBA code (see below) that helps validating email addresses but the user is required to enter the email address manually.

Sub email()
    Dim txtEmail As String
    txtEmail = InputBox("Type the address", "e-mail address")
    
    Dim Situacao As String
    
     ' Check e-mail syntax
    If IsEmailValid(txtEmail) Then
        Situacao = "Valid e-mail syntax!"
    Else
        Situacao = "Invalid e-mail syntax!"
    End If
     ' Shows the result
    MsgBox Situacao
End Sub
Function IsEmailValid(strEmail)
    Dim strArray As Variant
    Dim strItem As Variant
    Dim i As Long, c As String, blnIsItValid As Boolean
    blnIsItValid = True
    
    i = Len(strEmail) - Len(Application.Substitute(strEmail, "@", ""))
    If i <> 1 Then IsEmailValid = False: Exit Function
    ReDim strArray(1 To 2)
    strArray(1) = Left(strEmail, InStr(1, strEmail, "@", 1) - 1)
    strArray(2) = Application.Substitute(Right(strEmail, Len(strEmail) - Len(strArray(1))), "@", "")
    For Each strItem In strArray
        If Len(strItem) <= 0 Then
            blnIsItValid = False
            IsEmailValid = blnIsItValid
            Exit Function
        End If
        For i = 1 To Len(strItem)
            c = LCase(Mid(strItem, i, 1))
            If InStr("abcdefghijklmnopqrstuvwxyz_-.", c) <= 0 And Not IsNumeric(c) Then
                blnIsItValid = False
                IsEmailValid = blnIsItValid
                Exit Function
            End If
        Next i
        If Left(strItem, 1) = "." Or Right(strItem, 1) = "." Then
            blnIsItValid = False
            IsEmailValid = blnIsItValid
            Exit Function
        End If
    Next strItem
    If InStr(strArray(2), ".") <= 0 Then
        blnIsItValid = False
        IsEmailValid = blnIsItValid
        Exit Function
    End If
    i = Len(strArray(2)) - InStrRev(strArray(2), ".")
    If i <> 2 And i <> 3 Then
        blnIsItValid = False
        IsEmailValid = blnIsItValid
        Exit Function
    End If
    If InStr(strEmail, "..") > 0 Then
        blnIsItValid = False
        IsEmailValid = blnIsItValid
        Exit Function
    End If
    IsEmailValid = blnIsItValid
End Function

I would like to change the first portion of the code so that the following logic can be applied:

1. if email is valid: Do nothing (i.e. go to next cell in the selected range)
2. if email is NOT valid: delete cell containing invalid email

Courtesy of @Fluff on a different thread i have managed to list a number of email addresses in an array but i am not savvy enough to alter @Fluff's code so that a cell containing an invalid email address is deleted. At the moment, it deletes all cells regardless of the validation status.
Thanks for your suggestions.
My code proposal, which is not working as i need it to, is as follows :

Sub test()
    Dim lRow As Long
    Dim txtEmail As String
    Dim n As Integer
    Dim status As String
    
    screenupdate = False
    
    lRow = Cells(Rows.Count, 1).End(xlUp).Row
    n = lRow
    
    ActiveSheet.Range("A1:A" & lRow).Select
    ' or
    ' ActiveSheet.Range("A2").CurrentRegion.Select
    
    Set rng = Selection
    
    For n = lRow To 1 Step -1
        
       ' Select email address within range
       txtEmail = ActiveSheet.UsedRange.Rows(n).Select
      
         ' Check e-mail syntax with Function from Paelo
         ' Credit: http://www.vbaexpress.com/kb/getarticle.php?kb_id=281#instr
        
         ' If Email is valid then do nothing
        If IsEmailValid(txtEmail) Then
            ' I'm writing this as i do not know how to tell VBA to do nothing ;-)
            status = "Valid Email Address"
            GoTo catch
            
        Else
            'If email is INVALID then Delete cell containing invalid email address
            Range("A" & n).Delete Shift:=xlUp
        End If
catch:
    Next
screenupdate = True

End Sub

I anticipate the following possible issues:

• Cell formatting in the excel range (currently formatted as general or text)
• order of "delete" command vs "Do nothing" (but not sure how to rearrange
• not telling excel correctly how to "Do Nothing" and move to the next cell
• not savvy enough a coder!!!

Thanks again.
L

 

[lricher]

Hello all,

i have come up with a solution.
can anyone help me make the process more efficient if at all possible?

Sub ValidateEmailList()
    
    Dim lRow As Long
    Dim txtEmail As String
    Dim n As Integer
    Dim status As String
    
    ' WORKSHEET CLEAN UP
    Application.ScreenUpdating = False
    Sheets("Sheet2 (2)").Select
    Range("b:d").EntireColumn.Delete
    Sheets("sheet2").Range("a1").EntireColumn.Copy
    Sheets("Sheet2 (2)").Range("a1").Select
    ActiveSheet.Paste
    ' DELETE WORKSHEET CLEAN UP AFTER TRIALS
    
    'Application.ScreenUpdating = False
    lRow = Cells(Rows.Count, 1).End(xlUp).Row
    n = lRow
    
    ActiveSheet.Range("A2").CurrentRegion.Select
    
    For n = lRow To 1 Step -1
        
       ' Select email address within range
       txtEmail = Cells(n, 1).Value
      
        If IsEmailValid(txtEmail) = False Then
        
            Range("A" & n & ":c" & n).Delete Shift:=xlUp

        End If
        Next
        
    Application.ScreenUpdating = True

End Sub

Thanks