VBA - Code to check EAN13 checkdigit not working?

NessPJ

Active Member
Joined
May 10, 2011
Messages
408
Office Version
  1. 365
Hi,

I made a sheet with the VBA code posted below.
In there i have 2 methods for checking/recalculating a EAN13 code checkdigit.
But both methods are not correct according to the GS1 website.
I tried looking online (including these forums) to find an improved version of the code, but i could not find it.

Both the CheckDigit and calculateCheckdigit functions use a different approach. But they both come with FALSE results when the EAN13 code is actually correct.
Example: 3270161023430 (where the checkdigit is the last 0 and GS1 validates that this code is correct).

Can anyone help me to get a working/correct EAN13 checkdigit calculator? :)

VBA Code:
Option Private Module

    Public Const Password As String = "1234"

Private Sub Start()

Dim ChecklistLR As Long
Dim Digit As String
Dim Result As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False

'Start routine

PROTOFF (Password)

Sheets("Controle").Range("C4:C5000").ClearContents

ChecklistLR = Sheets("Controle").Range("B65534").End(xlUp).Row

i = 0

For i = 4 To ChecklistLR Step 1
   
    Digit = Sheets("Controle").Range("B" & i).value
   
    Result = IsCodeValid2(Digit)        'i also tried IsCodeValid(Digit)
   
    Sheets("Controle").Range("C" & i).value = Result
   
Next i

'Einde routine

PROTON (Password)
  
Application.ScreenUpdating = True
Application.DisplayAlerts = True


End Sub

Function IsCodeValid(sNumber As String) As Boolean

    On Error Resume Next
    If Len(sNumber) < 8 Then Exit Function
    IsCodeValid = (Right(sNumber, 1) = IsCodeValid = CheckDigit(Left(sNumber, Len(sNumber) - 1)))
    If Err.Number <> 0 Then Debug.Print Now, sNumber, Err.Number, Err.Description
   
End Function

Function CheckDigit(ByVal gtin As String) As String

'general purpose check digit calculator
' given all figures except last one, calculate check digit as used for GTIN-8, GTIN-12, EAN13, EDI GLN, etc ...
'parameter: number as string, WITHOUT the last digit
'works with string length up to 254 char
' returns: the last digit
'author: Patrick Honorez - www.idevlop.com
' notes: provided without any warranties
' Copyleft as long as you keep this header intact
'help for algorithm can be found here:
' http://www.gs1.org/barcodes/support/check_digit_calculator#how

    Dim m() As String, lSum As Long, i As Integer
    Dim chk As Integer, large As Long, mult As Byte
    'store string into an array
    m = Split(StrConv(gtin, vbUnicode), Chr(0))
    mult = 3     'multiply initial value is 3
    ' calc right to left to start with 3 as multiply
    For i = UBound(m) - 1 To 0 Step -1    'ignore last value of array: it's always = to chr (0)
        lSum = lSum + Val(m(i)) * mult
        If mult = 3 Then mult = 1 Else mult = 3 'swap multiply value between 3 and 1
    Next i
     ' find difference between lSum and the 10 that's equal or greater
    wide = (lSum \ 10) * 10
    If large < lSum Then large = large + 10
    chk = large - lSum
    CheckDigit = CStr(chk)
   
End Function

Function IsCodeValid2(sNumber As String) As Boolean

    On Error Resume Next
    If Len(sNumber) < 8 Then Exit Function
    IsCodeValid2 = calculateCheckDigit(Left(sNumber, Len(sNumber) - 1))
    If Err.Number <> 0 Then Debug.Print Now, sNumber, Err.Number, Err.Description
   
End Function

Function calculateCheckDigit(value)

    lenval = Len(value)
    factor = 3
    Sum = 0
    For Index = lenval To 1 Step -1
        Sum = Sum + (CInt(Mid(value, Index, 1)) * factor)
        factor = 4 - factor
    Next
    calculateCheckDigit = ((1000 - Sum) Mod 10)
   
End Function

Private Function PROTOFF(Password As String)
   
' Loop through all sheets in the workbook and unprotect

    For i = 1 To Sheets.Count

    Sheets(i).Unprotect (Password)

    Next i

End Function


Private Function PROTON(Password As String)

' Loop through all sheets in the workbook and protect
   
    For i = 1 To Sheets.Count
   
    Sheets(i).Protect DrawingObjects:=True, Contents:=True, AllowUsingPivotTables:=True, Scenarios:=True _
    , AllowFiltering:=True, Password:=Password

    Next i

End Function
 

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.

yky

Well-known Member
Joined
Jun 7, 2011
Messages
1,880
Office Version
  1. 2010
Platform
  1. Windows
You need to start from UBound(m) - 2 because the array index starts from 0, not 1.

VBA Code:
    For i = UBound(m) - 2 To 0 Step -1    'ignore last value of array: it's always = to chr (0)
 

Forum statistics

Threads
1,175,488
Messages
5,897,691
Members
434,673
Latest member
kktfc

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top