【Access】レコードセットを使って連番を振る

レコードセットで一覧表示

人的ミスにより簡単にデータの内容が書き換えられてしまうのは設計上避けたいと思っているので確認とかはレコードセットにしたソースをフォームで表示させるようにしています。

【Access】レコードセットをフォームのソースにする

【Access】レコードセットをフォームのソースにする（ＳＱＬの検索キーが数値型の場合）

一覧表示に連番を振りたい！

今回の案件は、レコードセットをソースにした一覧表示に連番を振りたいという事になります。

どうやって連番をふればいいんだ！？と悩んだ末に、フィールド（TNOとしました）を追加して、そこにレコードソースにするタイミングで連番を書き込むような仕組みにしました。

レコードソースを表示するVBAは下記のようになります。

これにより、入力日で抽出して、月日で並び替えているデータが表示されるようにしています。

Private Sub reload_Click()
 Dim cn As ADODB.Connection
 Dim rs As ADODB.Recordset

'   連番振るルーチン
Call TNO_CAL　

On Error GoTo Err_Handler

    Set cn = CurrentProject.AccessConnection
    Set rs = New ADODB.Recordset

            With rs
            Set .ActiveConnection = cn
            .Source = "SELECT * FROM Clearing_data WHERE ID =" & GID & " AND 入力日 Between #" & Me!date_start & "# AND #" & Me!date_end & "#" & " ORDER BY 月日 DESC"
            .LockType = adLockOptimistic
            .CursorType = adOpenKeyset
            .Open
            End With

        Set Me.Recordset = rs
        rs.Close: Set rs = Nothing
        cn.Close: Set cn = Nothing

ExitErr_Handler:
        ユーザー名 = DLookup("社員名", "User", "ID= " & GID)
        Exit Sub

Err_Handler:
        MsgBox "エラー： " & Err.Description
        rs.Close: Set rs = Nothing
        cn.Close: Set cn = Nothing
End Sub

Call　TNO_CAL　にて、連番を振るVBAに飛ぶようにしました。

連番振るVBA

Sub TNO_CAL()

Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim SQL As String
Dim i As Integer

On Error GoTo ErrRtn

    SQL = "SELECT * FROM Clearing_data WHERE ID =" & GID & " AND 入力日 Between #" & Me!date_start & "# AND #" & Me!date_end & "#"
'    & " ORDER BY NO ASC;"
    
    Set cn = CurrentProject.Connection
    Set rs = New ADODB.Recordset
    
    cn.CursorLocation = adUseClient
    rs.Open SQL, cn, adOpenKeyset, adLockOptimistic
    rs.Sort = "NO ASC"
    
    cn.BeginTrans
    
            i = 0
        
        Do Until rs.EOF
        
            i = i + 1
        
            rs!TNO = i
            
'            Debug.Print rs!NO
           
            rs.Update
            rs.MoveNext
        
        Loop
    
    cn.CommitTrans
    
    rs.Close: Set rs = Nothing
    cn.Close: Set cn = Nothing

ExitErrRtn:
    Exit Sub

ErrRtn:
    MsgBox "エラー： " & Err.Description
    cn.RollbackTrans
    rs.Close: Set rs = Nothing
    cn.Close: Set cn = Nothing

End Sub

ここで注意しなければならないのが、

その為、仕方なく、「rs.Sort = "NO ASC"」にて、並び替えをやっています。

それから、「cn.CursorLocation = adUseClient」を入れないと下記の様なエラーがでますので御注意ください。

なんで、SQＬでの、ORDER BYにて並び替えが出来なかったのかは不明ですが、とにかく求める連番を振ることができたので良しとしました。