ExcelでAccessファイルで保存

by

Excelでデータを加工してプレーンなテーブルにできたら、ExcelのシートでそのテーブルをSQLの対象にしてデータ取得する方法は良いと思う。
Accessはコストの関係から購入していないこともあると思う。（私がそういう状態です）
Accessはなくても、Accessで管理するデータベースはExcelのVBAから作成したり、データを管理したりすることはできる。
データベースの中を簡単に見たり、管理したりするツールがAccessということ。

データベース作成

Private Sub CreateDB()
    '
    Const adOpenForwardOnly As Long = 0
    Const adLockPessimistic As Long = 2
    Const adCmdText As Long = 1
    '
    Const DBname As String = "metiiip.accdb"
    '
    Dim DBpath As String
    Dim tCat As Object
    Dim cn As Object
    Dim rs As Object
    Dim conStr As String
    Dim sql As String
    '
    Dim tIndMsts As colIndMsts
    Dim tIndMst As clsIndMst
    '
    Dim tCitems As colCItems
    Dim tCitem As clsCItem
    '
    Set tIndMsts = tManage.colIndMsts
    Set tCitems = tManage.colCItems
    DBpath = ThisWorkbook.Path & "\"
    If deleteDB() Then
        Set tCat = CreateObject("ADOX.Catalog")
        conStr = "Provider = Microsoft.ACE.OLEDB.12.0;Data Source = " & DBpath & DBname & ";"
        Set cn = tCat.Create(conStr)    'データベース作成
        Set tCat = Nothing
        sql = "Create Table IndMst (Id short,IndId short,Name varchar);"  'Table作成
        cn.Execute (sql)
        sql = "Create Table ItemList (Id char(8),ParentId short,Name varchar);"  'Table作成
        cn.Execute (sql)
        Set rs = CreateObject("ADODB.Recordset")    'Recordset生成
        sql = "select * from IndMst;"
        rs.Open sql, cn, adOpenForwardOnly, adLockPessimistic, adCmdText
        For Each tIndMst In tIndMsts
            rs.addnew
                rs("Id").Value = tIndMst.SrgId
                rs("IndId").Value = tIndMst.IndId
                rs("Name").Value = tIndMst.IndName
            rs.Update
        Next
        rs.Close
        '
        sql = "select * from ItemList;"
        rs.Open sql, cn, adOpenForwardOnly, adLockPessimistic, adCmdText
        For Each tCitem In tCitems
            rs.addnew
                rs("Id").Value = tCitem.Id
                rs("ParentId").Value = tCitem.ParentId
                rs("Name").Value = tCitem.Name
            rs.Update
        Next
        '
        rs.Close
        cn.Close
        Set rs = Nothing
        Set cn = Nothing
    End If
    Call getTable
End Sub

ＳＱＬでInsert

Private Sub CreateDBSql()
    '
    Const adOpenForwardOnly As Long = 0
    Const adLockPessimistic As Long = 2
    Const adCmdText As Long = 1
    '
    Const DBname As String = "metiiip.accdb"
    '
    Dim DBpath As String
    Dim tCat As Object
    Dim cn As Object
    Dim conStr As String
    Dim sql As String
    '
    Dim tIndMsts As colIndMsts
    Dim tIndMst As clsIndMst
    '
    Dim tCitems As colCItems
    Dim tCitem As clsCItem
    '
    Set tIndMsts = tManage.colIndMsts
    Set tCitems = tManage.colCItems
    DBpath = ThisWorkbook.Path & "\"
    '
    If deleteDB() Then
        Set tCat = CreateObject("ADOX.Catalog")
        conStr = "Provider = Microsoft.ACE.OLEDB.12.0;Data Source = " & DBpath & DBname & ";"
        Set cn = tCat.Create(conStr)    'データベース作成
        Set tCat = Nothing
        sql = "Create Table IndMst (Id short,IndId short,Name varchar);"  'Table作成
        cn.Execute (sql)
        sql = "Create Table ItemList (Id char(8),ParentId short,Name varchar);"  'Table作成
        cn.Execute (sql)
        For Each tIndMst In tIndMsts
            With tIndMst
                sql = "insert into IndMst (Id,IndId,Name) values (" & .SrgId & "," & .IndId & ",'" & .IndName & "');"
                cn.Execute (sql)
            End With
        Next
        For Each tCitem In tCitems
            With tCitem
                sql = "insert into ItemList (Id,ParentId,Name) values ('" & .Id & "'," & .ParentId & ",'" & .Name & "');"
                cn.Execute (sql)
            End With
        Next
        cn.Close
        Set cn = Nothing
    End If
    Call getTable
End Sub

データベースは一旦削除して新規に作る設定にしてみたので、事前の削除機能が必要。
同じファイル名で拡張子が「.laccdb（ロック状態）」のファイルが残ってしまった状態だと削除できない。
手動で確認しないといけない。

Private Function deleteDB() As Boolean    
    Const DBname As String = "metiiip.accdb"
    '
    Dim DBpath As String
    Dim Ans As VbMsgBoxResult
    Dim Fso As Object
    Set Fso = CreateObject("Scripting.FileSystemObject")
    DBpath = ThisWorkbook.Path & "\"
    deleteDB = True
    If Not Dir(DBpath & DBname) = "" Then
        Ans = MsgBox("DBファイルが存在します。削除して良いですか？", vbYesNo, "DB削除")
        If Ans = vbNo Then
            deleteDB = False
            Exit Function
        Else
            On Error Resume Next
            Fso.GetFile(DBpath & DBname).Delete
            If Not Err.Number = 0 Then
              MsgBox "削除できません。ファイル使用中の可能性があります。", vbYes, "削除不可"
              deleteDB = False
            End If
            On Error GoTo 0
        End If
    End If
    Set Fso = Nothing
End Function

登録されたかどうか打ち出してみる。

Private Sub getTable()
    Const DBname As String = "metiiip.accdb"
    '
    Dim DBpath As String: DBpath = ThisWorkbook.Path & "\"
    Dim cn As Object
    Dim rs As Object
    Dim conStr As String
    Dim sql As String
    Dim selRange As Range
    '
    shTable.Select
    Set selRange = Cells(1, 1).CurrentRegion
    selRange.Offset(1, 0).ClearContents
    '
    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    cn.Provider = "Microsoft.ACE.OLEDB.12.0"
    cn.Open DBpath & DBname
    sql = "select M.IndId as MID,M.Name as MName,L.Id as LId, L.Name as LName from IndMst M inner join ItemList L  on M.Id = L.ParentId"
    rs.Open sql, cn
    
    If Not rs Is Nothing Then
        Range("A2").CopyFromRecordset Data:=rs
    End If
    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
End Sub

2つのテーブルに分けて作成し、JOINして打ち出してみたけど、Excelからの一連の処理で利用するだけあれば、正規化する必要もないので、JOINしてある1つの冗長なテーブルの方が便利かも。