Access テーブルの全データに対して、桁溢れチェックを行いたい

Question

実現したいこと

Access のテーブルの全データに対して、桁溢れチェックを行いたい。

ここに実現したいことを箇条書きで書いてください。

• AccessDB の 1つのテーブル（以下、T_本）の全データに対し、桁溢れしていないかチェックをしたい。
• 最終列に "桁溢れ" という名称のフィールドを1つ追加し、そこに "桁溢れしたフィールド名"を追加したい。

T_本：

欲しい結果：

前提

• 画像では6フィールドしかチェックしてないが、実際は40フィールド程度ある。
• 各フィールドにそれぞれ上限桁数が決まっている

試したこと

①テーブルAに "桁溢れ" フィールドを追加
②テーブルAをレコードセットとして取得し、1レコードずつ桁あふれチェックする。
③桁あふれが発生したら、カレントレコードの最終列に移動し、桁溢れしたフィールド名を書き込む。

Sub test()

'桁溢れ列追加
CurrentDb.Execute "ALTER TABLE [T_本] ADD COLUMN [桁溢れ] TEXT(255)"
'レコードセット取得
Dim rs As New ADODB.Recordset
rs.Open "T_本", CurrentProject.Connection

'レコードセット
Do Until rs.EOF
  Dim var As Variant
  Dim fld As ADODB.Field
  'フィールド移動
  For Each fld In rs.Fields
    [桁溢れしていたら最終フィールドへ移動して、フィールド名を書き込む]
    [移動元のフィールドへ戻る]
  Next fld
  rs.MoveNext
Loop
rs.Close

End Sub

問題点

[桁溢れしていたら最終フィールドへ移動して、フィールド名を書き込む]
ここの処理が分かりません。
そもそも、"桁溢れ発生" ⇒ "最終フィールドへ移動" ⇒ "移動元のフィールドへ戻る" なんてことはできるのでしょうか？

補足情報（FW/ツールのバージョンなど）

office365 Access

Answer 1

こんな感じでどうでしょう。

ただし、

• DAO向けに書かれているのでADOなら適宜書き換えが必要。
• Microsoft Scripting Runtimeが参照設定されているので、されていない環境ならCreateObject("Scripting.Dictionary")に書き換えが必要。
• 「桁溢れ」列の「ALTER TABLE」は処理済とし割愛。

Sub test()
    
    Dim dicRule As Dictionary
    Dim strOverflowColNames As String
    Dim varColName  As Variant
    Dim rst As Recordset
    
    Const conSeparater  As String = "、"
        
    Set dicRule = New Dictionary
    dicRule.Add "タイトル", 8
    dicRule.Add "著者", 7
    dicRule.Add "出版社", 6
        
    Set rst = CurrentDb.OpenRecordset("T_本")
    Do Until rst.EOF
        strOverflowColNames = vbNullString
        For Each varColName In dicRule
            If (Len(rst(varColName).Value) > dicRule(varColName)) Then
                strOverflowColNames = strOverflowColNames & conSeparater & varColName
            End If
        Next
        
        If strOverflowColNames <> vbNullString Then
            rst.Edit
            rst("桁溢れ") = Mid(strOverflowColNames, Len(conSeparater) + 1)
            rst.Update
        End If
        rst.MoveNext
    Loop
    
    Set rst = Nothing
    Set dicRule = Nothing
End Sub

Comments

[kappa]

ああ、意味的には、
Dim varColName As Variant
For Each varColName In dicRule
If (Len(rst(varColName).Value) > dicRule(varColName)) Then
strOverflowColNames = strOverflowColNames & conSeparater & varColName
End If
Next

よりも

Dim i As Integer
For i = 0 To dicRule.Count - 1
If (Len(rst(dicRule.Keys(i)).Value) > dicRule.Items(i)) Then
strOverflowColNames = strOverflowColNames & conSeparater & dicRule.Keys(i)
End If
Next i

のほうが伝わりやすいかもしれないですね。

また、関数が条件を変えて複数回実行されるなら
If strOverflowColNames <> vbNullString Then
の判定をなくしてvbNullString の場合に"桁溢れ"列がリセットされた方がいいですね。

Answer 2

[桁溢れしていたら最終フィールドへ移動して、フィールド名を書き込む]
[移動元のフィールドへ戻る]

桁溢れの結果を代入する変数を1つ用意しておけば良いかと思います。
以下、サンプルになります。

Sub Test()
    CurrentDb.Execute "ALTER TABLE [T_本] ADD COLUMN [桁溢れ] TEXT(255)"
    'レコードセット取得
    Dim rs As New ADODB.Recordset
    '更新モードでオープン
    rs.Open "T_本", CurrentProject.Connection, adOpenKeyset, adLockOptimistic
    
    '桁数判定用辞書
    Dim dic
    Set dic = CreateObject("Scripting.Dictionary")
    
    'フィールド毎の上限文字数（バイト数）
    dic.Add "タイトル", 20
    dic.Add "著者", 8
    dic.Add "出版社", 8
    
    'レコードセット
    Do Until rs.EOF
      Dim var As Variant
      Dim fld As ADODB.Field
      Dim strOverflow As String
      Dim bFirst As Boolean
      
      '初期化
      bFirst = True
      strOverflow = ""
      
      'フィールド移動
      For Each fld In rs.Fields
        '桁溢れ判定
        If IsOverflowColumn(dic, fld) Then
            '初回なら
            If bFirst Then
                'フィールドの値を変数に設定
                strOverflow = fld.Name
                bFirst = False
            '2回目以降であれば
            Else
                'フィールドの値を変数に追記
                strOverflow = strOverflow & "、" & fld.Name
            End If
        End If
      Next fld
      'チェック結果を代入
      rs("桁溢れ") = strOverflow
      rs.MoveNext
    Loop
    rs.Close

End Sub

' 桁溢れ判定関数
Function IsOverflowColumn(dic, fld As ADODB.Field) As Boolean
    Dim strFieldName As String
    Dim strFieldValue As String
    Dim nLimitSize As Long
    
    If TypeName(fld.Value) = "String" Then
        strFieldValue = fld.Value
    Else
        IsOverflowColumn = False
        Exit Function
    End If
    
    strFieldName = fld.Name
    If dic.Exists(strFieldName) Then
        nLimitSize = dic(strFieldName)
        If LenB(strFieldValue) > nLimitSize Then
            IsOverflowColumn = True
            Exit Function
        End If
    End If
    
    IsOverflowColumn = False
    
End Function

Comments

[access]

ご丁寧にありがとうございました。