EXCELにORマッピング機能を実装する

ExcelとDBの連携したアプリ開発を考えている

DBというのは、DB単体ではアプリとは言えず、人にとってのアクセス性が確保されて、やっとDBアプリケーションになる。

ここでExcelを一つのDBアプリケーションと見立てた場合に、
ひとつ課題になってくるのが、DB上で内部結合されたテーブルのデータを
いかにシート上に、見える化して、かつデータの新規作成、更新、削除といった
作業をやりやすくするかということが課題となる。

開発言語、VBAのアーキテクチャ

Excelで使える開発言語といえば、VBAである。
VBAは、オブジェクト指向言語ではないため、DB構造をそっくり
オブジェクト化してプログラム内部で扱えるような高等言語ではない

ここんところが課題である。

他の言語の場合

Java、JavaScript、Pythonなどは、データ自体をオブジェクトとして取り扱える。
データの内部結合も、辞書型の配列をつかえばさくっとできる

Excelの課題

DBの内部キーでリレーションされているようなデータに対して、
どのようにビューアーに表示させたり、ユーザーインターフェースを実現したらいいのだろうか？
オブジェクトのリレーション関係のマッピング（つまりORマッパー）を
VBAで自前で実装していかなければならない

やり方

DBへのリンクは、シート上にDAOを使ってテーブルのフィールド、レコードを持ってくる
VBAからのアクセスをしやすくするために、テーブルオブジェクトを作ってしまえばいい

ここからがやっかい
リレーションシップに関しては、DB上から関係テーブルを持ってくる必要がある
ACCESSの場合は、システムテーブルMsysRelationShipに書かれている
しかしながら、このテーブルにはExcel側からアクセスはできない
やり方としては、ACCESSオブジェクトを作って、そこからcmd関数でテキストfileをエクスポートして、Excel側からはtextfileからテーブルオブジェクトを生成すればいい
あとはリレーションのテーブルを参照して、シート側のテーブルの外部キーを、すべて内部プログラムで書き換えて、列単位でセルに入力規制をかける

これでいわゆるACCESS上のルックアップフィールドと呼ばれている機能がExcel側のDBアプリケーションで実現できる

詳細コード

• 下記のアクセスDB用のクラスを作成
• DBへのリンクは、シート上にDAOを使ってテーブルのフィールド、レコードを持ってくる VBAからのアクセスをしやすくするために、テーブルオブジェクトを作ってしまえばいい

'EXCELシートとアクセスデータベースの接続クラス
'
'version 1.0
'data 2018/09/11
'author M.Tamazawa MM05162

Option Explicit

Public WST As Worksheet  '対象とするワークシート
Public SQL_OPTION As String
Private datarow As Integer
Private dbPath As String
Private con As New ADODB.Connection
Private mRS As New ADODB.RecordSet
Private list_rows As Collection
Private table As Variant
Const dbFile As String = "MEP2019.accdb"
Const RelTBL As String = "MSysRelationships"

Private Sub DB切断()
    mRS.Close
    con.Close
    Set mRS = Nothing
    Set con = Nothing
End Sub

Public Sub 更新()
    DB接続
    DB読込
    DB切断
    TABLE作成
End Sub

Private Sub TABLE作成()
    On Error GoTo エラー処理
    Set table = WST.ListObjects.Add
    table.name = WST.name
    Exit Sub
エラー処理:
    MsgBox "テーブルは作成済みです。"
End Sub


Private Sub DB読込()
    Dim i
    WST.Range("a2").CurrentRegion.Clear
    With mRS
        For i = 0 To .Fields.count - 1
            WST.Cells(1, i + 1).Value = .Fields(i).name
        Next i
    End With
    WST.Range("a2").CopyFromRecordset DATA:=mRS
End Sub

Public Sub データ追加更新()
    Dim i
    Dim data_r As Variant
    If Chk行選択 Then
        DB接続

        For Each data_r In list_rows
        With mRS
            .MoveFirst
            .Find Criteria:=.Fields(0).name & "='" & WST.Cells(data_r, 1) & "'"
            If .EOF = True Then
            .AddNew
        End If
        For i = 1 To .Fields.count - 1
            .Fields(i).Value = WST.Cells(data_r, i + 1).Value
        Next i
        .Update
        .MoveFirst
        End With
    Next
    DB読込
    DB切断
    End If
End Sub

Private Function Chk行選択() As Boolean
    If list_rows Is Nothing Then
        MsgBox "行が選ばれていません"
        Chk行選択 = False
        Exit Function
    End If
    If MsgBox("行" & list_rows(1) & "から" & list_rows.count & "個のデータを処理しますか？", vbOKCancel) = vbOK Then
        Chk行選択 = True
    Else
        Chk行選択 = False
    End If
End Function

Public Sub データ削除()
    Dim i
    Dim data_r As Variant
    If Chk行選択 Then
        DB接続
    For Each data_r In list_rows
        With mRS
        .MoveFirst
        .Find Criteria:=.Fields(0).name & "='" & Cells(data_r, 1).Value & "'"
        If .EOF = True Then
            MsgBox "該当するレコードは存在しません。"
            DB切断
            Exit Sub
        End If
        .Delete
        .MoveFirst
        End With
    Next
    DB読込
    DB切断
  End If
End Sub

Private Sub DB接続()
    Dim SQL As String
    Dim sheetname As Variant
    Dim i As Integer
    Dim TableName As String
        'SQL_OPTION = FrmDbAccess.TextBox1
    TableName = WST.name        'シート名が、そのままACCESSテーブル名にリンクする
    con.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & dbPath & dbFile
    con.Open
    SQL = "SELECT * FROM " & TableName & " " & SQL_OPTION  'クエリ検索オプションを指定して、SQL読込をする
    'MsgBox SQL
    mRS.Open SQL, con, adOpenKeyset, adLockOptimistic, adLockReadOnly
End Sub

Property Set SetRange(ByVal rngs As Variant)
    Dim list_ As New Collection
    Dim rng As Variant
    For Each rng In rngs
        list_.Add rng.row
    Next
    Set list_rows = list_
End Property

Private Sub Class_Initialize()
    Set WST = ActiveSheet
    dbPath = ActiveWorkbook.Path & "\..\"
End Sub

Private Sub Class_Terminate()
    'MsgBox ("データベースを閉じました")
End Sub

本題のコード

• ACCESSから、システムテーブルMsysRelationShipを持ってくる
• cmd関数にてテーブルをcsv出力する
• EXCELでcsvファイルを開く
• リレーションテーブルを作成する

Const RelFile As String = "relation.csv"
Const ccolumn = 1
Const grbit = 2
Const icolumn = 3
Const szColumn = 4
Const szObject = 5
Const szReferencedColumn = 6
Const szReferencedObject = 7
Const szRelationship = 8
Property Get RelationTBL() As Variant
Set RelationTBL = Sheets(RelTBL)
End Property

Sub リレーション抽出()
    Dim objACCESS As Object
    With CreateObject("Access.Application")
    .OpenCurrentDatabase dbPath & dbFile
    .DoCmd.TransferText acExportDelim, , RelTBL, dbPath & "relation.csv", True
    End With
    If isExistingSheetName(RelTBL) Then
    With ActiveWorkbook.Sheets.Add(after:=Worksheets(Worksheets.count))
    .name = RelTBL
    Set WST = Sheets(RelTBL)
    End With
    End If
    csvInput
    TABLE作成
End Sub



' 指定の名前のワークシートが存在するかどうか
Function isExistingSheetName(sheetname As String) As Boolean
    Dim WS As Worksheet
    Dim flag As Boolean
    '現在のシートを記憶
    For Each WS In Worksheets
        If WS.name = sheetname Then flag = True
    Next WS
    If flag = True Then
        isExistingSheetName = False
    Else
        isExistingSheetName = True
    End If
End Function


Private Sub csvInput()
With WST.QueryTables.Add _
(Connection:="TEXT;" & dbPath & RelFile, Destination:=Range("A1"))
    .TextFilePlatform = 932          ' 文字コードを指定
    .TextFileParseType = xlDelimited ' 区切り文字の形式
    .TextFileCommaDelimiter = True   ' カンマ区切り
    .RefreshStyle = xlOverwriteCells ' セルに上書き
    .Refresh                         ' データを表示
    .Delete                          ' CSV との接続を解除
End With
End Sub

リレーションテーブルの参照

• リレーションテーブルの中身から関係テーブル、フィールドを読み取る
• ループを回して、関係するテーブルのリンクを参照 -　ディクショナリに外部キーとフィールド（１個だけ）を読み込む -　シートのセルを外部キーで書き換える

これから、列単位でセルに入力規制をかけるところは作成中

Sub Relation構築()
'WST リレーションテーブル

Dim rel1, tbl1, rel2, tbl2
Dim i As Integer: i = 2
With WST.ListObjects(1).Range
Do While .Cells(i, grbit) = 2
rel1 = .Cells(i, szColumn)
tbl1 = .Cells(i, szObject)
rel2 = .Cells(i, szReferencedColumn)
tbl2 = .Cells(i, szReferencedObject)
RelationSettingSheet rel1, tbl1, rel2, tbl2
i = i + 1
Loop
End With
End Sub

Private Sub RelationSettingSheet(rel1, tbl1, rel2, tbl2)
Dim i
Dim before
Dim myDic As Object
Set myDic = CreateObject("Scripting.Dictionary")
i = 2
With Sheets(tbl2).ListObjects(1).Range
Do
myDic.Add .Cells(i, 1).Value, .Cells(i, 2).Value
i = i + 1
Loop Until .Cells(i, 1) = ""
End With

With Sheets(tbl1).ListObjects(1)
For i = 1 To .ListRows.count
before = .ListColumns(rel1).Range.Cells(i + 1)
.ListColumns(rel1).Range.Cells(i + 1) = myDic(before)
Next
End With
End Sub