テーブルＡの変化によってテーブルBを作成する

今日は、半日
「テーブルAのレコード数分のデータを
テーブルBのフィールド名として使ってテーブルを作成する」という
まどろっこしいが、必要に迫られたコードを組んで終わってしまった．．．

項目のチェックを行うフォームがあるんですが
その項目が時期により増減するので
それを変更できるようにという訳ですが
（DB的にはあまりよろしくないことはわかっていても）

ここで問題になったのは、
カラムの増減をどうやって実現するかで
テーブルの存在有無をチェックするのに
http://blog.at-links.biz/?p=6
を参考にさせていただきました。

Option Compare Database

'−−−−−−−−−−−−−−−−−−−−−−−−−
'概要 ：テーブル存在チェック(ADO)
'−−−−−−−−−−−−−−−−−−−−−−−−−
'引数 ：strTblNm ＝ 存在をチェックするテーブル名
'−−−−−−−−−−−−−−−−−−−−−−−−−
'戻り値：True ＝ テーブルは存在する , False ＝　テーブルは存在しない
'−−−−−−−−−−−−−−−−−−−−−−−−−
Public Function GetTableExec(strTblNm As String) As Boolean
    Dim cnn As New ADODB.Connection
    Dim adrTbl As ADODB.Recordset
    Dim varTbl As Variant
    
    Set cnn = CurrentProject.Connection
    
    GetTableExec = False 'デフォルトは存在しない(False)

    ' 配列で渡す値の説明
    ' →TABLE_CATALOG,TABLE_SCHEMA,TABLE_NAME,TABLE_TYPE
    varTbl = Array(Empty, Empty, strTblNm, "TABLE")
     ' テーブルのスキーマ情報を取得
    Set adrTbl = cnn.OpenSchema(adSchemaTables, varTbl)
    'テーブルがあればEOF=FalseなのでNOTとしTrueを返す
    GetTableExec = Not adrTbl.EOF

    adrTbl.Close
     Set adrTbl = Nothing
End Function

で、PGでもSEでもない自分の言い訳として冗長な部分は見逃してほしいのですが
テーブルBが存在していない場合は、テーブルAのデータ数分の
フィールドをテーブルAのデータをフィールド名としてテーブルBを新規作成する。
テーブルBが存在していた場合は、一旦、テーブルBを削除したうえで
テーブルAのデータ数分のフィールドをテーブルAのデータをフィールド名として
テーブルBを再作成するというコード。

Sub MyCreateTable()
    Dim cnn As New ADODB.Connection
    Dim rst As New ADODB.Recordset
    Dim cat As ADOX.Catalog
    Dim tbl As ADOX.Table
    Dim StrSQL As String
    Dim FldName As String
    Dim TblName As String
    
    TblName = "テーブルB"
    
    StrSQL = "SELECT t1.REHAMENUID, t1.REHA, t1.CNT " & _
            "FROM テーブルＡ As t1 " & _
            "ORDER BY t1.REHAMENUID;"
    
    Set cnn = CurrentProject.Connection

    DoCmd.SetWarnings False
    Application.Echo False
    
    With rst
        .Open StrSQL, cnn, adOpenKeyset, adLockOptimistic
        
        Set cat = New ADOX.Catalog
        cat.ActiveConnection = CurrentProject.Connection
        Set tbl = New ADOX.Table
        tbl.Name = TblName
        Set tbl.ParentCatalog = cat
    
        If GetTableExec(TblName) = True Then
        
        cat.Tables.Delete TblName
        
        With tbl
            .Columns.Append "REHAMENUID", adInteger
            .Columns.Item("REHAMENUID").Properties("AutoIncrement") = True
            .Columns.Append "RECDETAILSID", adInteger
 
            Do Until rst.EOF
                FldName = rst!REHA
                Debug.Print "FldNameは、" & FldName
                    .Columns.Append FldName, adInteger
                rst.MoveNext
            Loop
        End With
        cat.Tables.Append tbl
        
        Else
        
        With tbl
            .Columns.Append "REHAMENUID", adInteger
            .Columns.Item("REHAMENUID").Properties("AutoIncrement") = True
            .Columns.Append "RECDETAILSID", adInteger
 
            Do Until rst.EOF
                FldName = rst!REHA
                Debug.Print "FldNameは、" & FldName
                    .Columns.Append FldName, adInteger
                rst.MoveNext
            Loop
        End With
        cat.Tables.Append tbl
        
        
        End If
        
    End With

    Application.Echo True
    DoCmd.SetWarnings True
    
    Set cat = Nothing
    cnn.Close: Set cnn = Nothing
    Set rst = Nothing

End Sub

PGとかSEとかいう人たちには笑われるんでしょう。きっと。