Anzeige
Archiv - Navigation
452to456
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
452to456
452to456
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

EDIFACT EAN od. Zeichensatz prüfen

EDIFACT EAN od. Zeichensatz prüfen
15.07.2004 10:49:18
Bongartz
Hallo
für alle die mit EDI Edifact zu tun haben, kommt es vor das die Daten auf konformität geprüft werden müssen.
Mit den folgenden Funktionen kan man die EAN Prüfziffer berechnen, die EAN Prüfen, den für EDIFACT zulässigen ASCII Zeichensatz für UNOA, UNOB oder UNOC überprüfen. Falsche ASCII Zeichen werden mit Ihrem Ascii-Code angezeigt.
Gruß
Bongartz


' Funktion ermittelt die korrekten EAN(8,13,14), UPC und DUN(14) Prüfziffern und
' übergibt die korrekt EAN in das Feld, von der die Funktion aufgerufen wurde.
Function GetEAN(strWert As StringAs Double
   Dim As Integer, nSumme As Byte, nLang As Byte
   Dim cWert As String, endWert As String
   Dim lGerade As Boolean
   Dim Länge As Byte
   Länge = Len(strWert)
 
   If IsNumeric(strWert) And Länge <> 0 Then
      Select Case Länge
      Case 8
         cWert = Left(strWert, 7)
         lGerade = False
         GoTo Berechnen
      Case 11
         cWert = Left(strWert, 10)
         lGerade = True
         GoTo Berechnen
      Case 12
         cWert = Left(strWert, 11)
         lGerade = False
         GoTo Berechnen
      Case 13
         cWert = Left(strWert, 12)
         lGerade = True
         GoTo Berechnen
      Case 14
         cWert = Left(strWert, 13)
         lGerade = False
         GoTo Berechnen
      Case Else
         Exit Function
      End Select
   End If
Berechnen:
   nLang = Len(cWert)
   For x = 1 To nLang
      lGerade = Not lGerade
      If lGerade Then
         nSumme = nSumme + Val(Mid$(cWert, x, 1)) * 3
      Else
         nSumme = nSumme + Val(Mid$(cWert, x, 1)) * 1
      End If
   Next x
   endWert = Int((nSumme + 9) / 10) * 10 - nSumme
   GetEAN = Int(cWert & endWert)
End Function
' Funktion ermittelt die korrekten EAN(8,13,14), UPC und DUN(14) Prüfziffern und
' übergibt in das Feld von der die Funktion aufgerufen wurde ein "***-OK" oder "Fehler".
Function CheckEAN(strWert As StringAs Variant
   Dim As Integer, nSumme As Byte, nLang As Byte
   Dim cWert As String, rWert As String, endWert As String, strEAN As String
   Dim lGerade As Boolean
   Dim Länge As Byte
   Länge = Len(strWert)
 
   If IsNumeric(strWert) And Länge <> 0 Then
      Select Case Länge
      Case 8
         strEAN = "OK EAN-8"
         rWert = Right(strWert, 1)
         cWert = Left(strWert, 7)
         lGerade = False
         GoTo Berechnen
      Case 11
         strEAN = "OK UPC 11 stellig"
         rWert = Right(strWert, 1)
         cWert = Left(strWert, 10)
         lGerade = True
         GoTo Berechnen
      Case 12
         strEAN = "OK UPC-12"
         rWert = Right(strWert, 1)
         cWert = Left(strWert, 11)
         lGerade = False
         GoTo Berechnen
      Case 13
         strEAN = "OK EAN-13"
         rWert = Right(strWert, 1)
         cWert = Left(strWert, 12)
         lGerade = True
         GoTo Berechnen
      Case 14
         strEAN = "OK EAN-14,DUN"
         rWert = Right(strWert, 1)
         cWert = Left(strWert, 13)
         lGerade = False
         GoTo Berechnen
      Case Else
         CheckEAN = "Fehler Keine EAN"
         Exit Function
      End Select
   End If
Berechnen:
   nLang = Len(cWert)
   For x = 1 To nLang
      lGerade = Not lGerade
      If lGerade Then
         nSumme = nSumme + Val(Mid$(cWert, x, 1)) * 3
      Else
         nSumme = nSumme + Val(Mid$(cWert, x, 1)) * 1
      End If
   Next x
   endWert = Int((nSumme + 9) / 10) * 10 - nSumme
   If rWert = endWert Then
      CheckEAN = strEAN
   Else
      CheckEAN = "Falsche Prüfziffer"
   End If
End Function
Function CheckUNOA(ByRef As Range) As Variant
'Prüft eine Zelle auf die korrekten Ascii zeichen für Edifact UNOA
  Dim laenge%, zeichen$, zahl, wert
  Dim As Integer
  Dim As Boolean
  zahl = ""
  laenge = Len(a)
  For i = 1 To laenge
    zeichen = Mid(a, i, 1)
    wert = Asc(zeichen)
    Select Case wert
      Case 32 To 34, 37, 38, 40 To 42, 44 To 57, 59 To 62, 65 To 90
      Case Else
         zahl = zahl & zeichen & "=" & wert & ", "
    End Select
  Next
  CheckUNOA = zahl
  
End Function
Function CheckUNOB(ByRef As Range) As Variant
'Prüft eine Zelle auf die korrekten Ascii zeichen für Edifact UNOB
  Dim laenge%, zeichen$, zahl, wert
  Dim As Integer
  Dim As Boolean
  zahl = ""
  laenge = Len(a)
  For i = 1 To laenge
    zeichen = Mid(a, i, 1)
    wert = Asc(zeichen)
    Select Case wert
      Case 32 To 34, 37, 38, 40 To 42, 44 To 57, 59 To 62, 65 To 90, 97 To 122
      Case Else
         zahl = zahl & zeichen & "=" & wert & ", "
    End Select
  Next
  CheckUNOB = zahl
  
End Function

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: EDIFACT EAN od. Zeichensatz prüfen
19.07.2004 13:48:52
Otto
Hallo Bongartz,
Meine Testumgebung: Excel 9.0 SR-1, Multilingual unter Windows 2000 SP-4
Da mich Dein GoTo Berechnen geärgert hat, habe ich die Funktion GetEAN verbessert.

Gruß Otto

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige