連番をつけるには？ (ID:111867)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

' テスト.mdbのパスは環境に合わせて変更してください。
' Form1 に MSFlexGrid1 と Command1,Command2 を貼り付けてください。
' ただしデータに Null が含まれていた場合、正常に動作しません。
' テーブル内のフィールド [Day] は日付型です。
Option Explicit

Private cnn As New ADODB.Connection
Private recData As ADODB.Recordset  ' 注文テーブル用
Private recBase As ADODB.Recordset  ' 予約テーブル用

Private Const con_tCDMax As Integer = 3 ' tCD の桁数最大(4桁になるとメッセージが出る：エラー処理はしないで4桁で登録)

Private Sub Form_Load()
    cnn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" _
                         & "Data Source=C:\Data\テスト.mdb"
    cnn.Open
    
    MitumoriHyouji
End Sub

Private Sub Form_Unload(Cancel As Integer)
    cnn.Close
End Sub

Private Sub Command1_Click()
    Dim strData     As String
    Dim str_tCD     As String
    Dim dtmDay      As Date
    Dim strGyousya  As String
    Dim lngNewCode  As Long
    Dim lngUpDateCode  As Long
    Dim i           As Integer
    
    dtmDay = 0
    strGyousya = ""
    ' 新規追加時の tCD を最初に求めてしまう。
    'SELECT TOP 1 tCD FROM Atable ORDER BY tCD DESC
    strData = "   SELECT TOP 1 tCD" & _
              "     FROM Atable" & _
              " ORDER BY tCD DESC"
    
    Set recData = New ADODB.Recordset
    With recData
        .Open strData, cnn, adOpenStatic, adLockPessimistic
        If .RecordCount <= 0 Then
            lngNewCode = 0
        Else
            lngNewCode = CLng(.Fields("tCD").Value) + 1
        End If
    End With
    
    ' トランザクション処理開始
    cnn.BeginTrans
    On Error GoTo Rollback
    
    With recBase
        .MoveFirst
        For i = 1 To .RecordCount
            ' 日付か業者名が違った場合は tCD が存在するか検索
            If dtmDay <> CDate(.Fields("Day").Value) _
            Or strGyousya <> CStr(.Fields("Gyousya").Value) Then
                dtmDay = CDate(.Fields("Day").Value)
                strGyousya = CStr(.Fields("Gyousya").Value)
                'SELECT TOP 1 tCD FROM Atable WHERE Day = #xx/xx/xxxx# AND Gyousya = 'xx'
                strData = "SELECT TOP 1 tCD" & _
                          "  FROM Atable" & _
                          " WHERE Day = #" & Format(dtmDay, "mm/dd/yyyy") & "#" & _
                          "   AND Gyousya = '" & strGyousya & "'"
                Set recData = New ADODB.Recordset
                recData.Open strData, cnn, adOpenStatic, adLockPessimistic
                If recData.RecordCount <= 0 Then
                    ' 過去に同じ tCD が存在しなかった場合 lngNewCode で UpDate
                    lngUpDateCode = lngNewCode
                    lngNewCode = lngNewCode + 1
                    If Not (AtableUpDate(lngUpDateCode)) Then
                        GoTo Rollback
                    End If
                Else
                    ' 過去に同じ tCD が存在した場合その tCD で UpDate
                    lngUpDateCode = CLng(recData.Fields("tCD").Value)
                    If Not (AtableUpDate(lngUpDateCode)) Then
                        GoTo Rollback
                    End If
                End If
            Else
                ' 日付と業者名が前のレコードと同じ場合は lngUpDateCode で UpDate
                If Not (AtableUpDate(lngUpDateCode)) Then
                    GoTo Rollback
                End If
            End If
            
            ' 見積もりテーブルにチェック
            BtableUpDate
            .MoveNext
        Next i
    End With
    
    ' トランザクション処理コミット
    cnn.CommitTrans
    MitumoriHyouji
    Exit Sub
    
Rollback:
    Debug.Print Err.Description
    ' トランザクション処理ロールバック
    cnn.RollbackTrans
    MitumoriHyouji
End Sub

' 見積もりテーブル(Btable)でチェックの無いものをリストアップ
Private Sub MitumoriHyouji()
    Dim strBase As String
    Dim i As Integer
    
    'SELECT * FROM Btable WHERE Check = 0 ORDER BY Day, Gyousya
    strBase = "   SELECT *" & _
              "     FROM Btable" & _
              "    WHERE Check = 0" & _
              " ORDER BY Day, Gyousya"
    
    Set recBase = New ADODB.Recordset
    With recBase
        .Open strBase, cnn, adOpenStatic, adLockPessimistic
        Me.MSFlexGrid1.Cols = 4
        Me.MSFlexGrid1.Rows = .RecordCount + 1
        Me.MSFlexGrid1.FormatString = "<日付          |<業者  |<品名  |<数量  "
        For i = 1 To .RecordCount
            Me.MSFlexGrid1.TextMatrix(i, 0) = .Fields("Day").Value
            Me.MSFlexGrid1.TextMatrix(i, 1) = .Fields("Gyousya").Value
            Me.MSFlexGrid1.TextMatrix(i, 2) = .Fields("Hinmei").Value
            Me.MSFlexGrid1.TextMatrix(i, 3) = .Fields("suuryou").Value
            .MoveNext
        Next i
    End With

End Sub

' 引数 tCDx で Atable にレコード追加
Private Function AtableUpDate(ByVal tCDx As Long) As Boolean
    AtableUpDate = False
    On Error GoTo ErrTrap
    
    Set recData = New ADODB.Recordset
    
    With recData
        .Open "Atable", cnn, adOpenStatic, adLockPessimistic
        .AddNew
        .Fields("tCD").Value = Format_tCD(tCDx)
        .Fields("Day").Value = recBase.Fields("Day").Value
        .Fields("Gyousya").Value = recBase.Fields("Gyousya").Value
        .Fields("Hinmei").Value = recBase.Fields("Hinmei").Value
        .Fields("suuryou").Value = recBase.Fields("suuryou").Value
        .Update
     End With
    
    AtableUpDate = True
    Exit Function
ErrTrap:
    Debug.Print Err.Description
End Function

' Btable にチェック
Private Function BtableUpDate() As Boolean
    BtableUpDate = False
    On Error GoTo ErrTrap
    
    With recBase
        .Fields("Check").Value = 1
    End With
    
    BtableUpDate = True
    Exit Function
ErrTrap:
    Debug.Print Err.Description
End Function

' tCD をデータベース登録の形にフォーマット
Private Function Format_tCD(ByVal tCDx As Long) As String
    Dim strZero As String
    Dim i As Integer
    If Len(CStr(tCDx)) > con_tCDMax Then
        MsgBox "コードが" & CStr(con_tCDMax) & "桁を越えました。"
    End If
    For i = 1 To con_tCDMax
        strZero = strZero & "0"
    Next i
    Format_tCD = Format(tCDx, strZero)
End Function

Private Sub Command2_Click()
    AtableDataCheck
End Sub

' 検証用関数
' 注文テーブル(Atable)で tCD が余分に発番されているものをリストアップ
Private Sub AtableDataCheck()
    Dim strData As String
    Dim i As Integer
    
    'SELECT * FROM Atable WHERE Check = 0 ORDER BY Day, Gyousya
    strData = "   SELECT tCD, Day, Gyousya" & _
              "     FROM Atable" & _
              " GROUP BY tCD, Day, Gyousya" & _
              " ORDER BY Day, Gyousya"
    
    Set recBase = New ADODB.Recordset
    With recBase
        .Open strData, cnn, adOpenStatic, adLockPessimistic
        Me.MSFlexGrid1.Cols = 3
        Me.MSFlexGrid1.Rows = .RecordCount + 1
        Me.MSFlexGrid1.FormatString = "<tCD   |<日付          |<業者  "
        For i = 1 To .RecordCount
            Me.MSFlexGrid1.TextMatrix(i, 0) = .Fields("tCD").Value
            Me.MSFlexGrid1.TextMatrix(i, 1) = .Fields("Day").Value
            Me.MSFlexGrid1.TextMatrix(i, 2) = .Fields("Gyousya").Value
            .MoveNext
        Next i
    End With
    
    With Me.MSFlexGrid1
        For i = 2 To recBase.RecordCount
            If .TextMatrix(i, 1) = .TextMatrix(i - 1, 1) _
            And .TextMatrix(i, 2) = .TextMatrix(i - 1, 2) Then
                .Row = i
                .Col = 0
                .CellBackColor = vbRed
            End If
        Next i
    End With

End Sub

←解決時は質問者本人がここをチェックしてください。

戻る