tjekke syntax på emailliste i excel

Koden anbringes under arkfanen (højreklik / Vis programkode / indsæt kode i VBA-vinduet

Tilret iflg. bemærkninger

Luk vinduet

Start koden med Alt+F8 / marker testAfEmails / afspil koden
----------------

Const førsteRække = 1          '<-- tilrettes
Const sidsteRække = 600        '<--
Public Sub testAfEmails()
Rem email er her i kolonne A (tilret) fejlmelding i kolonne B (tilret)
Rem alle rækker behandles - idet email kontrolleres af funktionen

    For ræk = førsteRække To sidsteRække
        If IsValidEMailAddress(Range("A" & ræk)) = False Then
            Range("B" & ræk) = "FEJL"
        End If
    Next ræk
End Sub
Private Function IsValidEMailAddress( _
      ByVal EMailAddress As String, _
      Optional ByVal Strict As Boolean = False _
  ) As Boolean
 
' Return True if the email address referenced is valid, False otherwise.
 
  Const Domain_Extensions = "|aero|biz|com|coop|edu|gov|info|int|mil|museum|name|net|org|pro|travel|"
  Const Country_Extensions = "|ac|ad|ae|af|ag|ai|al|am|an|ao|aq|ar|as|at|au|aw|ax|az|ba|bb|bd|be|bf|bg|bh|bi|bj|bm|bn|bo|br|bs|bt|bv|bw|by|bz|ca|cc|cd|cf|cg|ch|ci|ck|cl|cm|cn|co|cr|cs|cu|cv|cx|cy|cz|de|dj|dk|dm|do|dz|ec|ee|eg|eh|er|es|et|eu|fi|fj|fk|fm|fo|fr|ga|gb|gd|ge|gf|gg|gh|gi|gl|gm|gn|gp|gq|gr|gs|gt|gu|gw|gy|hk|hm|hn|hr|ht|hu|id|ie|il|im|in|io|iq|ir|is|it|je|jm|jo|jp|ke|kg|kh|ki|km|kn|kp|kr|kw|ky|kz|la|lb|lc|li|lk|lr|ls|lt|lu|lv|ly|ma|mc|md|mg|mh|mk|ml|mm|mn|mo|mp|mq|mr|ms|mt|mu|mv|mw|mx|my|mz|na|nc|ne|nf|ng|ni|nl|no|np|nr|nu|nz|om|pa|pe|pf|pg|ph|pk|pl|pm|pn|pr|ps|pt|pw|py|qa|re|ro|ru|rw|sa|sb|sc|sd|se|sg|sh|si|sj|sk|sl|sm|sn|so|sr|st|sv|sy|sz|tc|td|tf|tg|th|tj|tk|tl|tm|tn|to|tp|tr|tt|tv|tw|tz|ua|ug|uk|um|us|uy|uz|va|vc|ve|vg|vi|vn|vu|wf|ws|ye|yt|yu|za|zm|zw|"
  Const Invalid_Chars = "/'\"";:?!()[]{}^| "
  Const Invalid_Chars_Strict = "/'\"";:?!()[]{}^|$&*+=`<>,% "
  Const Invalid_Domains = "|aso|dnso|icann|internic|pso|afrinic|apnic|arin|example|gtld-servers|iab|iana|iana-servers|iesg|ietf|irtf|istf|lacnic|latnic|rfc -editor|ripe|root-servers|nic|whois|www|arpa|"
 
  Dim Index As Long
  Dim Extension As String
  Dim Domain As String
  Dim Position1 As Long
  Dim Position2 As Long
 
  If Len(EMailAddress) = 0 Then
      IsValidEMailAddress = True
      Exit Function
  End If
 
  EMailAddress = LCase(EMailAddress)
 
  ' Check for invalid characters
  If Strict Then
      For Index = 1 To Len(EMailAddress)
        If InStr(Invalid_Chars_Strict, Mid(EMailAddress, Index, 1)) > 0 Then
            Exit Function
        End If
      Next Index
  Else
      For Index = 1 To Len(EMailAddress)
        If InStr(Invalid_Chars, Mid(EMailAddress, Index, 1)) > 0 Then
            Exit Function
        End If
      Next Index
  End If
 
  ' Check for valid extension
  Index = InStrRev(EMailAddress, ".")
  If Index = 0 Then Exit Function
  Extension = Mid(EMailAddress, Index + 1)
  If InStr(Domain_Extensions, "|" & Extension & "|") = 0 And InStr(Country_Extensions, "|" & Extension & "|") = 0 Then Exit Function
 
  ' Check for consecutive dots
  If InStr(EMailAddress, "..") > 0 Then Exit Function
 
  ' Check for more than one ampersand
  If InStr(Replace(EMailAddress, "@", " ", Count:=1), "@") > 0 Then Exit Function
 
  ' Check for text prior to the ampersand
  Index = InStr(EMailAddress, "@")
  If Not Index > 1 Then Exit Function
 
  ' Check for a period after the ampersand
  If Mid(EMailAddress, Index + 1, 1) = "." Then Exit Function
 
  Position1 = InStr(EMailAddress, "@") + 1
  Position2 = InStr(Position1, EMailAddress, ".") - 1
  Domain = Mid(EMailAddress, Position1, Position2 - Position1 + 1)
 
  If Strict Then
      ' Check for single character domain
      If Len(Domain) = 1 Then Exit Function
      ' Check for an invalid domain
      If InStr(Invalid_Domains, "|" & Domain & "|") > 0 Then Exit Function
      If InStr(Domain_Extensions, "|" & Domain & "|") > 0 Then Exit Function
  End If
 
  ' Check for dash in the first, last, third, or fourth position of the domain
  If Left(Domain, 1) = "-" Then Exit Function
  If Right(Domain, 1) = "-" Then Exit Function
  If Len(Domain) > 2 Then
      If Mid(Domain, 3, 1) = "-" Then Exit Function
      If Len(Domain) > 3 Then
        If Mid(Domain, 4, 1) = "-" Then Exit Function
      End If
  End If
 
  ' Check for more then 67 characters in the domain and extension
  If Len(Domain) + Len(Extension) > 67 Then Exit Function
 
  IsValidEMailAddress = True

End Function

præcis som supertekst skriver ....

ellers er der her en slim udgave af den du allerede selv har fundet, den tjekker ikke for lige så meget som den ovenstående. Tjekker kun for de tegn du skrev.

Alt+F11 opret et modul, hvor du smider koden ind, også kan du ellers bare sætte koden igang.
Nedenstående koden kører efter at mails står i D kolonnen, men det kan du blot ændre i linien (Range("D1").Select)

Sub tjekMail()
Dim cell As String
Dim clen As String
Dim x As Long
Dim count As Integer
Dim mail As Boolean
Const ulovligeTegn = "æøåÆØÅ?!#¤%&/\()=£$µ;:, "

Range("D1").Select
While Not ActiveCell.Value = ""
    mail = True
    cell = ActiveCell.Value
    clen = Len(cell)
    count = 0
    For x = 1 To clen
        If InStr(1, ulovligeTegn, Mid(cell, x, 1)) > 0 Then
            mail = False
        End If
        If InStr(1, "@", Mid(cell, x, 1)) = 1 Then
            count = count + 1
        End If
        If count > 1 Or mail = False Then
            Exit For
        End If
    Next
    If mail Then
        With Selection.Interior
            .ColorIndex = 4
            .Pattern = xlSolid
        End With
    Else
        With Selection.Interior
            .ColorIndex = 3
            .Pattern = xlSolid
        End With
    End If
    ActiveCell.Offset(1, 0).Select
Wend
End Sub

Tak, jeg har fået det til at virke.

hvordan accepterer jeg jeres løsninger og giver jer point og lukker tråden?

Giv point til #2 - så du må bede om er svar, som du så skal acceptere  - og afvise dit eget svar.

kom med et svar, så du kan få dine point, og jeg kan lukke tråden.

et svar herfra - så du kan lukke....