Accessで採番テーブルを使用して年度ごとの自動採番する方法について紹介したいと思います。
こちらは主に請求書や見積書等にそれぞれ一意のID（コード）を採番したい時に使用します。
共有DBに採番テーブルを作成して、それを使用して採番処理をVBAで行えば
一意のコードを自動生成することが可能となります。
採番テーブルを作成する
まずは採番テーブルを作成します。
用途により必要な項目を定義していきます。
今回は、年度により切替される採番テーブルを作成しました。
採番ルールを考えます
1:請求ID →”SQ” & 年(2桁) & “-” & 0001～自動採番
2:入金ID →”NK” & 年(2桁) & “-” & 0001～自動採番
2:入金ID →”NK” & 年(2桁) & “-” & 0001～自動採番
テーブル名：t_saiban
(項目)
saiban_id：オートナンバー
saiban_div：数値型
nendo：短いテキスト
フィールドサイズ：4
備考：西暦yyyy
new_id：数値型
no：短いテキスト
フィールドサイズ：10
note
データイメージ
画面を作成する
テキスト1
名前：txt請求ID
テキスト2
名前：txt入金ID
ボタン１
名前：cmd採番請求ID
ボタン２
名前：cmd採番入金ID
VBA
標準モジュールに下記のコードを記載します
Option Compare Database Option Explicit Public Const C_SAIBAN_請求ID = 1 Public Const C_SAIBAN_入金ID = 2
CONSTは定数といって変更することのない固定の値です。
採番テーブルより新IDを取得する
Rem ----------------------------------------------------------------------------------
Rem 関数名 : getNewId
Rem 処理内容 : 採番テーブルより新IDを取得
Rem 引 数 : なし
Rem 戻り値 : 新台帳ID
Rem ----------------------------------------------------------------------------------
Public Function getNewId(pSaiban_div As Integer, pNendo As String) As String
Dim objRs As Recordset
Dim strSql As String
Dim strNo As String
Dim newId As Long
On Error GoTo Error
' SQL実行
strSql = "SELECT * FROM t_saiban"
strSql = strSql & " WHERE saiban_div = " & pSaiban_div & " "
strSql = strSql & " AND nendo = '" & pNendo & "'"
Set objRs = CurrentDb.OpenRecordset(strSql, dbOpenDynaset)
If objRs.RecordCount = 1 Then
' データがある時はIDをカウントアップ
newId = Nz(objRs.Fields("new_id"), 0) + 1
'-------------------------------------------------------
' 1:請求ID →"SQ" & 年(2桁) & "-" & 0001～自動採番
' 2:入金ID →"NK" & 年(2桁) & "-" & 0001～自動採番
'-------------------------------------------------------
Select Case pSaiban_div
Case C_SAIBAN_請求ID
strNo = "SQ" & Right(pNendo, 2) & "-" & funSetEditCode(STR(newId), 4)
Case C_SAIBAN_入金ID
strNo = "NK" & Right(pNendo, 2) & "-" & funSetEditCode(STR(newId), 4)
Case Else
End Select
objRs.Edit
objRs!new_id = newId
objRs!No = strNo
objRs.Update
Else
' データがない時は新規に採番(年度変わった時）
newId = 1
objRs.AddNew
objRs!saiban_div = pSaiban_div
objRs!nendo = pNendo
objRs!new_id = newId
'-------------------------------------------------------
' 1:請求ID →"SQ" & 年(2桁) & "-" & 0001～自動採番
' 2:入金ID →"NK" & 年(2桁) & "-" & 0001～自動採番
'-------------------------------------------------------
Select Case pSaiban_div
Case C_SAIBAN_請求ID
strNo = "SQ" & Right(pNendo, 2) & "-" & funSetEditCode(STR(newId), 4)
Case C_SAIBAN_入金ID
strNo = "NK" & Right(pNendo, 2) & "-" & funSetEditCode(STR(newId), 4)
Case Else
End Select
objRs!No = strNo
objRs.Update
End If
' 後処理
objRs.Close: Set objRs = Nothing
getNewId = strNo
Exit Function
Error:
MsgBox "エラーが発生しました。エラー内容：" & Err.Description & Chr$(10), vbCritical, "ID取得"
End Function
採番テーブルより現在のIDを取得
Rem ----------------------------------------------------------------------------------
Rem 関数名 : getSaibanId
Rem 処理内容 : 採番テーブルより現在のIDを取得する
Rem 引 数 : なし
Rem 戻り値 : ID
Rem ----------------------------------------------------------------------------------
Public Function getSaibanId(pSaiban_div As Integer, pNendo As String) As String
Dim objRs As Recordset
Dim strSql As String
Dim strNo As String
Dim saibanId As Long
On Error GoTo Error
' SQL実行
strSql = "SELECT * FROM t_saiban"
strSql = strSql & " WHERE saiban_div = " & pSaiban_div & " "
strSql = strSql & " AND nendo = '" & pNendo & "'"
Set objRs = CurrentDb.OpenRecordset(strSql, dbOpenDynaset)
If objRs.RecordCount = 1 Then
saibanId = Nz(objRs.Fields("new_id"), 0)
Select Case pSaiban_div
Case C_SAIBAN_請求ID
strNo = "SQ" & Right(pNendo, 2) & "-" & funSetEditCode(STR(saibanId), 4)
Case C_SAIBAN_入金ID
strNo = "NK" & Right(pNendo, 2) & "-" & funSetEditCode(STR(saibanId), 4)
Case Else
End Select
End If
' 後処理
objRs.Close: Set objRs = Nothing
getSaibanId = strNo
Exit Function
Error:
MsgBox "エラーが発生しました。エラー内容：" & Err.Description & Chr$(10), vbCritical, "ID取得"
End Function
コードを０埋め編集して返却
Rem ----------------------------------------------------------------------------------
Rem 関数名 : funSetEditCode
Rem 処理内容 : コードを０埋め編集して返却します
Rem 引 数 : code = 編集前のコード
Rem lenCnt = 桁数
Rem 戻り値 : 編集結果
Rem ----------------------------------------------------------------------------------
Public Function funSetEditCode(code As String, lenCnt As Integer) As String
On Error GoTo Error
If Nz(code) = "" Then
funSetEditCode = ""
Exit Function
End If
funSetEditCode = Format(code, String(lenCnt, "0"))
Exit Function
Error:
MsgBox "エラーが発生しました。エラー内容：" & Err.Description & Chr$(10), vbCritical, "０埋め編集"
End Function画面表示
フォームの開くイベントを表示します。
Private Sub Form_Open(Cancel As Integer)
' 請求IDを取得
Me.txt請求ID.Value = getSaibanId(C_SAIBAN_請求ID, "2024")
' 入金IDを取得
Me.txt入金ID.Value = getSaibanId(C_SAIBAN_入金ID, "2024")
End Sub請求ID採番
請求ID採番ボタンのクリックイベントに記載します。
Private Sub cmd採番請求ID_Click()
' 請求IDを採番して再セットする
Me.txt請求ID.Value = getNewId(C_SAIBAN_請求ID, "2024")
End Sub動きを確認
画面表示時
請求IDのボタンを押下
getNewId関数がコールされて採番テーブルより該当のIDを取得し
請求IDの場合は、その所定のルールにあうように採番処理をしてIDが返却されるので
それを画面のテキストに再表示しています。
コメント