すごいコードから着想を得る

Accessなしでデータベースを作成する。
というものすごい天才的なコードが示されているのですが、ふと思いました。
「これを使うとEXCEL 2016 64bit」でもEXCELからMDBファイルが作れるのでは!?

今のところバグが出ますが、できないことはないようです。

環境

Office 2016 64bit (Access 2010 ODBCドライバ入り）+　Win10 Home

参照設定

Microsoft ADO Ext 2.x for DDL and Security
Microsoft Active Data Objects 2.x Library
これを設定するということはそれ以外の6.0とかは外さないとエラーになります。
そして、これがHPにないのですが、
Microsoft Jet and Replication Object 2.6 Libraly
を加えます。

前提

上記のHPは設定表シートがあり、いくつかのシートからテーブルを作り、テーブルごとに主キーを加えるというむちゃくちゃなものです。
これでは実験する前に心がおれてしまいます。
そこで、Listというシートを作り、全部長整数型の数字（小数点がない）
ものを作ります。

Gapは差なのですが、式は入っていません。ここはVBAで計算して差を値だけ入れるためです。
なんでそんなことをしているかというと、13000行を超えているので計算式を入れていると遅くなるからです。
ここはsqlを作成する場合0を補う必要があります。

　そして、HPにもあるように該当するエクセルファイルのあるフォルダにDBというフォルダを作り、sample.mdbというファイルを作ります。既存のファイルがあれば、それを削除します。

宣言部分

ここで重要なのは

AccessVBA、ADOXでmdb作成
より
Const cnsConnect1 = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="
を
Const cnsConnect1 = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source="
に書き換えます。
これにともないcnsConnect2が不要になります。
バージョンがあがってMDBが扱えなくなったはずなのに・・・
あと当方は64ビットなので
Private Declare PtrSafe Function GetPrivateProfileString Lib
とPrtSafeが加わっています

makemdb.vb

Const cnsTitle = "MDBの作成(ADOX)"
Const cnsMDB_FILE = "\SAMPLE.mdb"
'///////////////
Const cnsConnect1 = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source="
'///////////////
'Const cnsConnect2 = ";Jet OLEDB:Engine Type=5;"
Const cnsSH0 = "設定"
Const cnsSH1 = "テーブル"
Type typKey
    KeyName As String
    KeyIdx As Integer
End Type
'■iniﾌｧｲﾙ読込み(String)
Private Declare PtrSafe Function GetPrivateProfileString Lib "KERNEL32.dll" _
    Alias "GetPrivateProfileStringA" ( _
    ByVal lpApplicationName As String, _
    ByVal lpKeyName As String, _
    ByVal lpDefault As String, _
    ByVal lpReturnedString As String, _
    ByVal nSize As Long, _
    ByVal lpFileName As String) As Long

Sub

makemdb.vb

Sub MAKE_MDB()
    Dim xlApp As Application
    Dim WBK As Workbook
    Dim SH As Worksheet
    Dim dbCat As ADOX.Catalog
    Dim dbTbl As ADOX.Table
    Dim dbKey As ADOX.Key
    Dim dbCon As ADODB.Connection
    Dim strDB_Path As String        ' MDBの収容フォルダ
    Dim strMDB As String            ' MDBの物理ファイル名
    Dim strConnect As String
    Dim GYO As Long
    Dim GYO1 As Long
    Dim GYO2 As Long
    Dim COL As Long
    Dim COL2 As Long
    Dim wrkKey As typKey
    Dim strSQL As String
    Dim strSQL1 As String
    Set xlApp = Application
    Set WBK = ActiveWorkbook
    Set SH = WBK.Worksheets("List")
    strDB_Path = FP_GET_INI_String("F-1", "DBPATH", WBK.Path & "\DB", _
        WBK.Path & "\F-1.ini")
    ' DBフォルダがなければ作成
    If Dir(strDB_Path, vbDirectory) = "" Then MkDir strDB_Path
    ' MDBは本ブックのフォルダの配下にある「DB」フォルダに作成
    strMDB = strDB_Path & cnsMDB_FILE
    If Dir(strMDB, vbNormal) <> "" Then
        ' MDBから新規作成するので、既にある場合は一旦削除
        If MsgBox(strMDB & vbCr & _
            "は既に存在しているので一旦削除して再生成します。" & vbCr & vbCr & _
            "よろしいですね？", _
            vbInformation + vbYesNo, cnsTitle) <> vbYes Then Exit Sub
        xlApp.DisplayAlerts = False
        Kill strMDB
        xlApp.DisplayAlerts = True
    End If
    strConnect = cnsConnect1 & strMDB '& cnsConnect2
    Set dbCat = New ADOX.Catalog
    ' Access2000形式のMDBファイルを新規作成
    dbCat.Create strConnect                                             ' ①
    DoEvents
    ' 作成したMDBに接続
    dbCat.ActiveConnection = strConnect
    GYO = 1
        GYO1 = GYO
        ' テーブルを作成する
        Set dbTbl = New ADOX.Table
        Set dbKey = New ADOX.Key
        cntKey = 0
        dbTbl.Name = "List"    ' テーブル名
        ' フィールドの登録
        Do While GYO < 5
            ' フィールドを追加
                dbTbl.Columns.Append SH.Cells(1, GYO).Value, dbLong ' ④
            GYO = GYO + 1
        Loop
        dbCat.Tables.Append dbTbl                                       ' ⑧

    ' オブジェクト変数の解放
    Set dbKey = Nothing
    Set dbTbl = Nothing
    Set dbCat = Nothing

'-------------------------------------------------------------------------------
' ■テーブルのレコードの入力
    Set dbCon = New ADODB.Connection
    dbCon.Open strConnect
        If ((SH.Name <> cnsSH0) And (SH.Name <> cnsSH1)) Then
            ' 最終行列の判定
            With SH.Cells.SpecialCells(xlCellTypeLastCell)
                GYO2 = .Row
                COL2 = .Column
            End With
            ' 最終行まで繰り返す
            GYO = 2
            strSQL1 = "INSERT INTO " & SH.Name & " VALUES("
            Do While GYO <= GYO2
  ' SQLの作成INSERT文を作成
                strSQL = strSQL1
                For COL = 1 To 4
                If SH.Cells(GYO, COL).Value <> "" Then
  ' Make Sql string with Padding 0 
                If COL <> 1 Then strSQL = strSQL & "," & SH.Cells(GYO, COL).Value: Debug.Print strSQL, COL, GYO Else strSQL = strSQL & SH.Cells(GYO, COL).Value
                Else
                If COL <> 1 Then strSQL = strSQL & "," & "0": Debug.Print strSQL, COL, GYO Else strSQL = strSQL & "0"
                End If
                Next COL
                strSQL = strSQL & ");"
                dbCon.Execute strSQL    ' INSERT文を実行
                GYO = GYO + 1
            Loop
        End If
    dbCon.Close
    Set dbCon = Nothing
    WBK.Saved = True
    MsgBox "MDBの作成が完了しました。", vbInformation, cnsTitle
End Sub

このあとは

Private Function FP_GET_INI_String
が必要になりますが、それは冒頭の参考サイトをご覧ください。
解説の〇つき数字は元のHPのプログラムと同じです。
　サブプロシージャも感心はされない方もいらっしゃると思いますが、このままでは高度過ぎて誰も理解できないまま埋もれてしまうので、シンプルな設定から変換するようにしました。また表現を変えて少しわかりやすい注記に変えました。でも過程を途中で切るとわけがわからないので、こんな長くなってしまいます。閉鎖したサイトのように検索よけとかじゃないよ。
　正直できるとは思わなかった。

プログラムの流れ

このサブプロシージャはフォルダを作る、ファイルを作る、テーブルを作る、データを流し込む、という流れでできています。元のプログラムがすごいのは設定表シートをもとに複数のシートからテーブルを作成するところでしょう。たしかにMDBのテーブルは今でもEXCEL2016からできてしまうのです。ということはaccdbのファイルも作れるのかもしれません。
元のファイルは日付形式は日付リテラルで挟むようにSELECT文を打つなど細かい配慮に満ち溢れていますが、今回はできるかどうかだけなので、こんなシンプルなものです。すいません。

残された謎

　ところで本当はかっこよく倍精度にしたかったのですが、dbDoubleにするとなぜか数字が日付になってしまうので、なくなくdbLongにしました。データの型式によっては作れないのもあるのかもしれません。

　しかしさらにわけがわからないのはこうやって作ったmdbファイル、access2016 64bitで開けるんです。しかもテーブルの設定が変えられるんです。
　さらにMicrosoft OLE DB Provider for Microsoft Jet はOffice 2013 Laterで現役なのです。
　日本語のmdbからaccdbに変換できることは以前書きました。
　ということは、Office2016でもmdbファイルもテーブルくらいならそこそこ扱えるみたいなのです。

補足

cnsConnect2の意味は
DAO から ADO への移植11
にあります。