Using Joel's algorithm function and a routine to loop through the 10
possible check digits, find the one that passes the algorithm and place it
in the adjacent column. Assuming your serial numbers are in column A,
starting at row 1, this will place the registration number in column B. The
actual starting point can be adjusted to fit in the code.
Sub AddCheckNum()
Dim LRow As Long, ctr As Integer
Dim TestNum As String
Dim rng As Range, c As Range
LRow = Cells(Rows.Count, 1).End(xlUp).Row 'change col num to suit
Set rng = Range("A1:A" & LRow) 'change col & start row to suit
For Each c In rng
For ctr = 0 To 9
TestNum = c.Value & ctr
If ValidateCardNumber(TestNum) Then
c.Offset(0, 1).Value = TestNum
Exit For
End If
Next
Next
End Sub
Public Function ValidateCardNumber(strCardNumber) As Boolean ' MOD 10
checkdigit. "Luhn algorithm"
On Error GoTo Err
Dim intLoop As Integer, intSum As Integer
Dim bIsAlternate As Boolean, intProduct As Integer
For intLoop = Len(strCardNumber) To 1 Step -1
If bIsAlternate = False Then
intSum = intSum + CInt(Mid(strCardNumber, intLoop, 1))
bIsAlternate = True
Else
intProduct = CInt(Mid(strCardNumber, intLoop, 1)) * 2
If Len(CStr(intProduct)) = 2 Then
intSum = intSum + CInt(Mid(intProduct, 1, 1)) +
CInt(Mid(intProduct, 2, 1))
Else
intSum = intSum + CInt(intProduct)
End If
bIsAlternate = False
End If
Next intLoop
If intSum Mod 10 = 0 Then
ValidateCardNumber = True
Else
ValidateCardNumber = False
End If
Exit Function
Err:
MsgBox "Error in ValidateCardNumber()" & vbCrLf & Err.Number &
Err.Description
End Function
Check for wordwrap in the VBA editor after you paste this into a standard
code module.
Mike F
