ダウンロード(自動採番機能(オートナンバー))

データをテキストファイル化して保存させる時にユニークなファイル名を発生させるなどで利用できる「自動採番機能」の組み込み用モジュールです。

なぜ、こんなことをしなければならないのか．．．   このコラムがなかった頃、「ワークシートのセルで自動採番すれば良いのではないか」という質問を頂いていました。
全くの「個人用」であればワークシートのセルでも良いのですが、社内の「業務用」となるとそうは行かないと言うのがこのページのサンプルになります。場合によっては複数の方がほぼ同時にこの「採番機能」を利用しようとした時の動作です。

①複数の人に同じ採番値を渡さないこと(排他で動作すること)
②１件の採番動作を失敗なく行ない「採番ファイル」を新しい採番値で保存できること
③１件の採番動作をできるだけ瞬時に行なうこと
④「採番ファイル」の排他動作等での失敗の場合は自動リトライできること

このような条件に対応できる仕組みです。
ネットワークデータベースが利用できるなら「採番テーブル」を作成する方法もありますが、ここでは一般的なファイルサーバで運用できるように「採番ファイル(テキストファイル)」で行なうサンプルとしています。

採番ファイルとのI/Oを一般的なInput/OutputやFSO(FileSystemObject)は用いずにバイナリ(Binary)モードとしているのは、読み書きの間を全てが終わるまで排他ロックさせるためです。
「排他ロック」というのは、一方で開いているファイルを、開いている間は他者が開くことができないようにするモードです。
入力(Input)モードで前回値を読み出して採番値を加算し、出力(Output)モードで書き出す方法だと、一瞬のことなので重複採番は運用上ではほとんど起きませんが、読み出しと書き出しとの間に一瞬の時間ができることには変わらないので排他ロックが保障されるわけではありません。

これを単にExcelシートのどこかのセルに採番値を書き込んで行なう方法にした場合の問題点は、

①新しい採番値は書き込まれたワークブックを保存しなければ次回に利用されない。
   ⇒これをおこたると採番値の重複が起きてしまう。
②一方で採番用ワークブックを開いている場合は他者は利用できない。
   ⇒共有ブックにしても保存で採番値が更新されることは同じなので、採番値自体の排他にはならない。

複数の利用者が絶対に同時利用しないのであれば、この方法でも良いことになります。
但し「絶対」であり、「たぶん」ではいけません。

組み込み用クラスモジュールと、サンプルを用意しました。

(この画像をクリックすると、ダウンロードができます。)
上記の画面のボタンから呼び出されるのがModule2にある「GP_GetNewNumber」です。
Module2の先頭の方に「採番関連設定値」とコメント説明がある定数があり、以下の機能になっています。

定数名	説明
g_cnsNumberFile	採番ファイルのファイル名です。このサンプルではドキュメントフォルダ配下にサブフォルダを作って配置するようにしていますが、実際の業務運用ではネットワーク上に配置されることが多いと思います。その場合はフルパスファイル名として下さい。
g_cnsNumberFolder	ドキュメントフォルダ配下にサブフォルダ名です。上記の採番ファイルのファイル名をフルパスで指定される場合は不要になります。
g_cnsNumberLen	採番値の上限桁数です。ここでは「6」になっていますが、この場合は採番値は「999999」が上限値となり、この次の採番時点で「1」に戻ります。
g_cnsPrefix	採番ファイル名のレコードのプレフィックス文字列です。ここでは「NUMBER-」になっていますが、この後に採番値が付加されるので、実際のレコードは「NUMBER-000001」というようになります。プレフィックスが不要な場合はブランクとして下さい。

それでは、Module2のコードです。
採番処理の中核部分はその下のclsAutoNumber2(クラスモジュール)になりますが、こちらはほとんどのケースで改変することなく利用できると思います。


'***************************************************************************************************
'   採番ファイル更新(起動部分)                                      Module2(Module)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'   [参照設定]
'   ・Microsoft Scripting Runtime
'   ・Windows Script Host Object Model
'***************************************************************************************************
' 変更日付 Rev   変更履歴内容---------------------------------------------------------------------->
' 22/07/20(2.0.0)新規作成
'***************************************************************************************************
Option Explicit
'---------------------------------------------------------------------------------------------------
Private Const g_cnsTitle As String = "採番ファイル更新②"
' 採番関連設定値
Private Const g_cnsNumberFile As String = "TEST_NUMBER.txt"         ' 採番ファイル名
Private Const g_cnsNumberFolder As String = "SAIBAN"                ' サブフォルダ名(TEST)
Private Const g_cnsNumberLen As Long = 6                            ' 採番値桁数
Private Const g_cnsPrefix As String = "NUMBER-"                     ' プレフィックス
'---------------------------------------------------------------------------------------------------
Private g_objAutoNumber As clsAutoNumber2                           ' 採番ファイル更新クラス
Private g_blnInitAutoNumber As Boolean                              ' クラス初期化判定

'***************************************************************************************************
'   ■■■ ワークシートからの呼び出し処理 ■■■
'***************************************************************************************************
'* 処理名　：GP_GetNewNumber
'* 機能　　：採番ファイルから新しい一連番号を受け取るサンプル
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2022年07月20日
'* 作成者　：井上　治
'* 更新日　：2022年07月20日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Sub GP_GetNewNumber()
    '-----------------------------------------------------------------------------------------------
    Dim objFso As FileSystemObject                                  ' FileSystemObject
    Dim lngNumber As Long                                           ' 採番値(数値)
    Dim strFolder As String                                         ' 採番ファイルのフォルダ
    Dim strFullname As String                                       ' フルパス名
    Dim strErrMSG As String                                         ' エラーメッセージ
    '-----------------------------------------------------------------------------------------------
    ' 採番値受け取り前の処理(所在フォルダがフルパス指定で固定できていれば不要)
    Set objFso = New FileSystemObject
    strFolder = FP_GetSaibanFolder(objFso)
    strFullname = objFso.BuildPath(strFolder, g_cnsNumberFile)
    Set objFso = Nothing
    '-----------------------------------------------------------------------------------------------
    ' クラス未初期化なら初期化を行なう
    If Not g_blnInitAutoNumber Then
        ' クラス初期化
        Set g_objAutoNumber = New clsAutoNumber2
        ' 設定初期値セット(戻り値は初期化済み判定値)
        g_blnInitAutoNumber = g_objAutoNumber.SetInitialValues(g_cnsNumberLen, _
                                                               g_cnsPrefix, _
                                                               strFullname)
    End If
    '-----------------------------------------------------------------------------------------------
    ' 自動採番値を受け取る
    If g_objAutoNumber.GetAutoNumber(lngNumber, strErrMSG) Then
        ' 成功⇒番号の表示
        MsgBox "今回の一連番号は、" & lngNumber & "番です。", _
            vbInformation, g_cnsTitle
    Else
        ' 不成功(エラーメッセージ表示)
        MsgBox strErrMSG, vbCritical, g_cnsTitle
    End If
End Sub

'***************************************************************************************************
' ※以下はテスト用に採番ファイルのフォルダを作成する工程であって、
' 　フルパスファイル名で指定できる場合には不要なものです。
'***************************************************************************************************
' 採番ファイルのフォルダをマイドキュメント配下の｢SAIBAN｣フォルダとして作成する
'***************************************************************************************************
Private Function FP_GetSaibanFolder(ByRef objFso As FileSystemObject) As String
    '-----------------------------------------------------------------------------------------------
    Dim strFolder As String                                         ' 採番ファイルのフォルダ
    With New WshShell
        strFolder = .SpecialFolders("MyDocuments")
    End With
    FP_GetSaibanFolder = objFso.BuildPath(strFolder, g_cnsNumberFolder)
    ' 採番ファイルのフォルダが無ければ作成
    If Not objFso.FolderExists(FP_GetSaibanFolder) Then
        objFso.CreateFolder FP_GetSaibanFolder
    End If
End Function

'------------------------------------------<< End of Source >>--------------------------------------

このModule2ではテスト動作がすぐにできるようにドキュメントフォルダを取得して配下に「SAIBAN」サブフォルダを作成するようにしていますが、実運用ではネットワーク上などに固定された採番ファイルで運用するはずなので、採番ファイル名はフルパスファイル名を定数で定義できるはずです。
この場合はModule2はこのようにシンプルになります。


'***************************************************************************************************
'   採番ファイル更新(起動部分：実運用サンプル)                      Module2(Module)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
' 変更日付 Rev   変更履歴内容---------------------------------------------------------------------->
' 22/07/20(2.0.0)新規作成
'***************************************************************************************************
Option Explicit
'---------------------------------------------------------------------------------------------------
Private Const g_cnsTitle As String = "採番ファイル更新②"
' 採番関連設定値
Private Const g_cnsNumberFile As String = _
    "\\[サーバ名]\[共有名]\[サブフォルダ名]\[ファイル名].txt"       ' 採番ファイル名(フルパス)
Private Const g_cnsNumberLen As Long = 6                            ' 採番値桁数
Private Const g_cnsPrefix As String = "NUMBER-"                     ' プレフィックス
'---------------------------------------------------------------------------------------------------
Private g_objAutoNumber As clsAutoNumber2                           ' 採番ファイル更新クラス
Private g_blnInitAutoNumber As Boolean                              ' クラス初期化判定

'***************************************************************************************************
'   ■■■ ワークシートからの呼び出し処理 ■■■
'***************************************************************************************************
'* 処理名　：GP_GetNewNumber
'* 機能　　：採番ファイルから新しい一連番号を受け取るサンプル
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2022年07月20日
'* 作成者　：井上　治
'* 更新日　：2022年07月20日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Sub GP_GetNewNumber()
    '-----------------------------------------------------------------------------------------------
    Dim lngNumber As Long                                           ' 採番値(数値)
    Dim strErrMSG As String                                         ' エラーメッセージ
    '-----------------------------------------------------------------------------------------------
    ' クラス未初期化なら初期化を行なう
    If Not g_blnInitAutoNumber Then
        ' クラス初期化
        Set g_objAutoNumber = New clsAutoNumber2
        ' 設定初期値セット(戻り値は初期化済み判定値)
        g_blnInitAutoNumber = g_objAutoNumber.SetInitialValues(g_cnsNumberLen, _
                                                               g_cnsPrefix, _
                                                               g_cnsNumberFile)
    End If
    '-----------------------------------------------------------------------------------------------
    ' 自動採番値を受け取る
    If g_objAutoNumber.GetAutoNumber(lngNumber, strErrMSG) Then
        ' 成功⇒番号の表示
        MsgBox "今回の一連番号は、" & lngNumber & "番です。", _
            vbInformation, g_cnsTitle
    Else
        ' 不成功
        MsgBox strErrMSG, vbCritical, g_cnsTitle
    End If
End Sub

'------------------------------------------<< End of Source >>--------------------------------------

採番ファイル更新クラス(clsAutoNumber2)のコードは以下のようになります。
こちらは利用者側で改変が必要になることはほとんどないものと思います。


'***************************************************************************************************
'   採番ファイル更新クラス                                          clsAutoNumber2(Class)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
' 変更日付 Rev   変更履歴内容---------------------------------------------------------------------->
' 22/07/20(2.0.0)新規作成
'***************************************************************************************************
Option Explicit
'---------------------------------------------------------------------------------------------------
#If VBA7 Then
'■スリープ
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
'■スリープ
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
'---------------------------------------------------------------------------------------------------
' 設定値
Private g_blnInitialized As Boolean                                 ' 初期化済判定
Private g_lngNumberLen As Long                                      ' 採番値数字部分桁数
Private g_lngNumberMax As Long                                      ' 採番値上限値
Private g_lngPrefixLen As String                                    ' プレフィックス桁数
Private g_strPrefix As String                                       ' プレフィックス
Private g_strNumberFormat As String                                 ' 番号フォーマット
Private g_strFilename As String                                     ' 採番ファイル名

'***************************************************************************************************
'   ■■■ 外部からの呼び出しプロシージャ ■■■
'***************************************************************************************************
'* 処理名　：SetInitialValues
'* 機能　　：設定初期値セット
'---------------------------------------------------------------------------------------------------
'* 返り値　：初期化済判定(Boolean)
'* 引数　　：Arg1 = 採番値数字部分桁数(Long)
'* 　　　　　Arg2 = プレフィックス(String)
'* 　　　　　Arg3 = 採番ファイル名(String)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2022年07月20日
'* 作成者　：井上　治
'* 更新日　：2022年07月20日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：クラス初期化直後に呼び出すこと、クラス存続時は再呼び出し不要
'***************************************************************************************************
Friend Function SetInitialValues(ByVal lngNumberLen As Long, _
                                 ByVal strPrefix As String, _
                                 ByVal strFilename As String) As Boolean
    '-----------------------------------------------------------------------------------------------
    ' 設定初期値の取込み
    g_lngNumberLen = lngNumberLen
    g_strPrefix = strPrefix
    g_strFilename = strFilename
    '-------------------------------------------------------
    g_lngPrefixLen = Len(g_strPrefix)
    g_strNumberFormat = String(g_lngNumberLen, "0")
    g_lngNumberMax = 10 ^ g_lngNumberLen - 1
    '-------------------------------------------------------
    ' 初期化済判定
    g_blnInitialized = True
    SetInitialValues = True
End Function

'***************************************************************************************************
'* 処理名　：GetAutoNumber
'* 機能　　：自動発番の番号を取得する
'---------------------------------------------------------------------------------------------------
'* 返り値　：処理成否(Boolean)
'* 引数　　：Arg1 = 採番値(Long)                            ※Ref参照
'* 　　　　　Arg2 = エラ－メッセージ(String)                ※Ref参照
'---------------------------------------------------------------------------------------------------
'* 作成日　：2022年07月20日
'* 作成者　：井上　治
'* 更新日　：2022年07月20日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Friend Function GetAutoNumber(ByRef lngNumber As Long, _
                              ByRef strErrMSG As String) As Boolean
    '-----------------------------------------------------------------------------------------------
    Dim intFF As Integer                                            ' FreeFile値
    Dim strREC As String                                            ' レコード内容
    Dim strNumber As String                                         ' レコード内容(採番値)
    Dim intCntErr As Integer                                        ' エラーカウンタ
    Dim lngWait As Long                                             ' Waitミリ秒
    Dim blnOpened As Boolean                                        ' ファイルOPEN判定

    GetAutoNumber = False
    strErrMSG = ""
    ' FreeFile値の取得(以降この値で入出力する)
    intFF = FreeFile
    On Error GoTo GetAutoNumber_OpenERROR
    ' 指定ファイルをOPEN(バイナリモード:排他OPEN)
    Open g_strFilename For Binary Lock Read Write As #intFF
    blnOpened = True
    On Error GoTo GetAutoNumber_ERROR
    ' レコード領域初期化(初期値埋め込み)
    strREC = String(g_lngNumberLen + g_lngPrefixLen, Chr(0))
    ' レコードの受取り
    Get #intFF, 1, strREC
    '-------------------------------------------------------
    ' 初回のファイル処理か判断
    If g_lngPrefixLen > 0 Then
        ' プレフィックスがあるか
        If Left(strREC, g_lngPrefixLen) = g_strPrefix Then
            ' 採番値登録済み
            strNumber = Mid(strREC, g_lngPrefixLen + 1, g_lngNumberLen)
            lngNumber = CLng(strNumber)
            ' 上限値でなければ前回値に1を加える
            If lngNumber >= g_lngNumberMax Then
                ' 最大値到達は「1」に復帰
                lngNumber = 1
            Else
                ' 前回№に「1」を加える
                lngNumber = lngNumber + 1
            End If
        Else
            ' 初回は初期値をセット
            lngNumber = 1
        End If
    ElseIf IsNumeric(strREC) Then
        ' プレフィックスなし
        lngNumber = CLng(strREC)
        ' 上限値でなければ前回値に1を加える
        If lngNumber >= g_lngNumberMax Then
            ' 最大値到達は「1」に復帰
            lngNumber = 1
        Else
            ' 前回№に「1」を加える
            lngNumber = lngNumber + 1
        End If
    Else
        ' 初回は初期値をセット
        lngNumber = 1
    End If
    '-------------------------------------------------------
    ' 書き戻すレコードを編集(プレフィックス＋採番値)
    strREC = g_strPrefix & Format(lngNumber, g_strNumberFormat)
    ' 採番レコードの出力(同位置で置き換える)
    Put #intFF, 1, strREC & vbCrLf
    '-------------------------------------------------------
    GetAutoNumber = True
    ' 終了
    GoTo GetAutoNumber_EXIT

'===============================================================================
' 採番ファイルのOPENエラー処理
GetAutoNumber_OpenERROR:
    strErrMSG = "採番ファイルがOPENできません。" & vbCr & _
        "  (" & Err.Description & ")"
    ' 乱数時間WAIT
    intCntErr = intCntErr + 1
    If intCntErr <= 10 Then
        lngWait = Int(998 * Rnd() + 1)
        Sleep lngWait
        Resume
    End If
    GoTo GetAutoNumber_EXIT

'===============================================================================
' 採番ファイルのその他エラー処理
GetAutoNumber_ERROR:
    ' 不成功の場合はエラ－メッセージを返す
    strErrMSG = "採番ファイルがREADできません。" & vbCr & _
        "  (" & Err.Description & ")"

'===============================================================================
' 終了
GetAutoNumber_EXIT:
    ' 指定ファイルをCLOSE
    If blnOpened Then
        On Error Resume Next
        Close #intFF
    End If
    On Error GoTo 0
End Function

'***************************************************************************************************
'   ■■■ プロパティ ■■■
'***************************************************************************************************
' 初期化済判定
'---------------------------------------------------------------------------------------------------
Friend Property Get prpInitialized() As Boolean
    '-----------------------------------------------------------------------------------------------
    prpInitialized = g_blnInitialized
End Property

'------------------------------------------<< End of Source >>--------------------------------------

先頭コラムでも触れましたが、本処理のファイルI/Oは「バイナリ(Binary)モード」です。
通常であれば「入力(Input)モード」で前回値を読み込んで1を加えて処理し、その結果を「出力(Output)モード」で書き出すという処理になるのですが、この「入力(Input)モード」から「出力(Output)モード」に移行するのに一旦ファイルを閉じなければならず、閉じることでほんの一瞬ですが、他からのファイル要求が割り込む可能性が発生してしまいます。

ここで、読み込み開始から書き出し完了までを1回のファイルOPENで行なえるのが「バイナリ(Binary)モード」なのです。
ファイル処理の説明は「バイナリモードでの読み書き」を参照して下さい。

内部では、排他バイナリOPENして現在番号を得て、そのまま「1」を加えて書き戻します。このため、複数箇所からアクセスされても同一番号を配給することはありません。 OPENの不成功では、ランダム時間(ミリ秒単位)待機し再試行するようになっています。

←AutoNumber2.zip
(35KB)

以下は旧サンプルです。

以前に本ページで公開していたものはクラス化されておらず、どちらかと言うと説明上の「コードサンプル」的な物でした。
採番値は8桁固定でプレフィックス無しに限定されています。
ここでの説明は省略させていただきますが、必要であれば下記ボタンでダウンロードできます。

←AutoNumber.zip
(26KB)