AccessVBA Do Loop グループ内のナンバリング（連番）設定 共有ロックエラー退避含む

元のレコード内のグループ内で連番を設定する。

新たなテーブルに連番を降ったレコードを追加してみた。

＜元データ＞

＜追加後の完成イメージ＞

商品ごと日付ごとに順位付けを行い、連番を振ったフィールドを追加した。

 回数フィールドに追加した連番を記述してある。

以下、VBAの記述

'------------------------------------------------------------------------------

Public Function createCount2()

Dim ws As Workspace
Dim db As Database
Dim rst As Recordset
Dim rst1 As Recordset

Dim strSQL As String
Dim strCode As String
Dim i As Integer
Dim cnt As Integer

DoCmd.SetWarnings False

’追加先のテーブルデータを消去
DoCmd.RunSQL "DELETE*FROM CountTbl2;"

'大量のデータを処理する場合、共有ロックエラーが起きるためその退避

Set ws = DBEngine.Workspaces(0) 

Set db = CurrentDb

'商品ごと日付ごとにソートをかける

strSQL = "SELECT originTbl.* FROM originTbl ORDER BY originTbl.商品 ASC, originTbl.日付 ASC;"

Set rst1 = db.OpenRecordset(strSQL, dbOpenSnapshot)

Set rst = db.OpenRecordset("CountTbl2")

If rst1.RecordCount <> 0 Then

ws.BeginTrans

i = 0

Do Until rst1.EOF

rst.AddNew

rst!日付 = rst1!日付
rst!商品 = rst1!商品
rst!数量 = rst1!数量

If strCode = rst1!商品 Then

i = i + 1

Else

strCode = rst1!商品

i = 1

End If

rst!回数 = i

cnt = cnt + 1

If cnt = 5000 Then

ws.CommitTrans
ws.BeginTrans

cnt = 0

End If

rst.Update
rst1.MoveNext

Loop

ws.CommitTrans

rst.Close
rst1.Close

db.Close
Set db = Nothing

ws.Close
Set ws = Nothing

End If

End Function

'------------------------------------------------------------------------------------------

以上、終わり。

大量データを処理する場合（10000レコード前後？）共有ロックエラーが出るので、

そのエラーを退避するための処理をリンクを参考に追加。

トランザクション処理（DAO）: アクセスVBA エクセルVBA 備忘録