Attribute VB_Name = "Module1"
'■　マクロ５００連発＜第２段＞
'
'　チェックデジットを計算する
'
'  Copyright(C) 2000 Sunago
'
'   　このサンプルではウェイト3-1のモジュラス10の計算方法を用いて
'   チェックデジットを求めます。たとえば、"497024010515x"の
'   13桁目のチェックデジットを求めるには、13桁を除いて右から
'   奇数桁に×1を、偶数桁を×3した和(nSum)を求めます。
'   その和を10で割った余り(nMod)から10引いた値がチェックデジット
'   となります。
'
'   計算例（ウェイト3-1のモジュラス10）
'
'　　　4  9  7  0  2  4  0  1  0  5  1  5  x
'　　　x  x  x  x  x  x  x  x  x  x  x  x
'　　　1  3  1  3  1  3  1  3  1  3  1  3
'
'　　　4+27+ 7+ 0 +2+12+ 0+ 3+ 0+15+ 1+15   =86
'
'　　　86 ÷ 10 = 8 余り 6
'　　　10 − 6 = 4
'
Option Explicit

Sub Macro1()
Dim sValue As String

    
    '基本例
    sValue = CheckDigitNo("4970240105150", 13)
    MsgBox sValue, , "497024010515x"
    'チェックデジット桁位置を省略しない例
    sValue = CheckDigitNo("497024010515", 13)
    MsgBox sValue, , "497024010515x"
    'チェックデジット桁位置を省略した例
    sValue = CheckDigitNo("497024010515")
    MsgBox sValue, , "497024010515x"
    'チェックデジット桁が偶数となる例
    sValue = CheckDigitNo("49541434", 8)
    MsgBox sValue, , "49541434x"
   
End Sub

'/* チェックデジットを求める関数 */
'
'引数
'　sNumber := 数値の文字列
'             チェックデジット桁を含む場合は"0"とする
'  sPositon:= チェックデジット桁位置
'             省略時はsNumberの桁数＋１

Function CheckDigitNo(sNumber As String, _
                        Optional nPosition As Integer = 0) As String
Dim nNumber() As Integer
Dim nSum As Integer
Dim nMod As Integer
Dim nLength As Integer
Dim sText As String
Dim i As Integer

    If sNumber <> StrConv(sNumber, vbNarrow) Then
    '引数(sNumber)に全角文字が含まれる場合はエラー
        CheckDigitNo = "#Error!"
        Exit Function
    ElseIf Not IsNumeric(sNumber) Then
    '引数(sNumber)に数字以外の文字が含まれる場合はエラー
        CheckDigitNo = "#Error!"
        Exit Function
    End If
    
    nLength = Len(sNumber)
    If nLength < nPosition Then
        nLength = nPosition
    ElseIf nPosition = 0 Then
        nLength = nLength + 1
        nPosition = nLength
    End If
        
    ReDim nNumber(1 To nLength)
    For i = 1 To nLength
        If i = nPosition Then
        'チェックディジットを求める桁は計算しない
        ElseIf ((i + (nLength Mod 2)) Mod 2) = 1 Then
        'チェックディジット桁を除いた右から奇数桁のウェイトを３とする
            nNumber(i) = Mid(sNumber, i, 1)
            nSum = nSum + CInt(nNumber(i)) * 3
        Else
        '偶数桁のウェイトを１とする
            nNumber(i) = Mid(sNumber, i, 1)
            nSum = nSum + CInt(nNumber(i)) * 1
        End If
    Next
    '
    nMod = nSum Mod 10
    nNumber(nPosition) = 10 - nMod
    For i = 1 To nLength
        sText = sText & CStr(nNumber(i))
    Next
    CheckDigitNo = sText
End Function