VBA応用(ワークシートからデータベースに一括登録)

一般に、データベースができたら初期データを登録します。

初期登録データはお持ちですか？今までExcelだけで管理していたデータをMDBに移行させようとする場合、 MDBに登録させる元データはワークシート上にあるわけですから、移行の初期段階ではワークシート上のデータをMDBに一括登録することになります。ここではAccessなしでこの一括登録をできるように考えてみましょう。「インポート」のような作業ツールです。

(画像をクリックすると、このページのサンプルがダウンロードできます)

これはダウンロードした「MDB(ACCDB)SampleCorp1.zip」の中にある「MDB(ACCDB)インポートデータ(テーブル操作サンプル).xlsm」を開いたところです。
前頁の「MDB(ACCDB)テーブル定義(テーブル操作サンプル).xlsm」で作成したデータベースに対して、部署マスタ、役職マスタ、社員マスタ、配属マスタそれぞれの初期データを１つのマクロの実行で一括して投入するようになっていますが、マクロのソースコードには「○○マスタが．．．．」というテーブル固有の記述は行なわず、それぞれの情報は上記のワークシートから得るように考えました。ですから、他の事例にも応用できると思います。

マクロのソースコードでテーブルやフィールドの記述を直接行なわないということから、Excel側でこれらの情報の指定ができるようにする必要があります。今回のサンプルでは、シート名を「テーブルID」、見出しを2行として1行目を「フィールドID」、 2行目を項目タイプとして全シートで統一しています。これでマクロの方は「どのシート」とか「どのテーブル」とかの特有の記述を行なわずに汎用的な記述で済むようにできるわけです。
なお、項目タイプは以下のように設定しており、見出しA列のコメントでも説明しています。

値	説明
0	文字列
1	整数
2	実数
3	BOOL
4	日付
5	時刻
6	文章

以下がソースコードです。
呼び出されるプロシージャが先頭の「MDBデータインポート」です。他に4つのプロシージャがありますが、全てPrivateですから、外部からは見えません。「MDBデータインポート」プロシージャでは「開く」ダイアログからMDB(ACCDB)ファイル名を受け取り、 MDB(ACCDB)の接続は「MDB(ACCDB)への接続(FP_ConnectMDB)」を呼び出します。その後はADOコマンドを生成した後で各ワークシートを巡回しながら「ワークシート単位処理(FP_WorksheetProc)」を呼び出します。

「ワークシート単位処理(FP_WorksheetProc)」はテーブル単位のデータ投入を行なう処理になります。
トランザクション処理としていて、途中で処理失敗があるとロールバックさせるようにしています。処理の先頭で対象テーブルに対してDELETE文のSQLを発行してテーブルを空にしてからワークシートの3行目から順次INSERT文を発行してデータ投入させるようになっています。
INSERT文の「INSERT INTO」～「VALUES」までは各行で共通なので、事前に別の変数に編集させておき、各行ではこれを呼び出してからセルのデータを編集させるようにしてあります。

なお、本処理ではフィールドがNULL許可になっているかどうかの判定は行なっていません。日付、時刻のフィールドではセル値がブランクの場合はNULLをセットしています。


'***************************************************************************************************
'   MDB(ACCDB)初期データインポートツール
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'   [参照設定]
'   ・Microsoft Scripting Runtime
'   ・Windows Script Host Object Model
'   ・Microsoft Active Data Objects 2.x Library
'***************************************************************************************************
' 変更日付 Rev   変更履歴内容---------------------------------------------------------------------->
' 16/12/20(1.0.0)新規作成
' 17/01/07(1.0.0)一部修正＋コメントの整備
' 19/11/24(1.1.0)MDB/ACCDB兼用版として再作成
'***************************************************************************************************
Option Explicit
'===================================================================================================
Private Const g_cnsTitle = "MDB(ACCDB)データインポート"
Private Const g_cnsSH1 = "原紙"
Private Const g_cnsFilter = "MDB(ACCDB)ファイル (*.mdb;*.accdb),*.mdb;*.accdb"
Private Const g_cnsADO_Connect1 = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source="""

'***************************************************************************************************
'* 処理名　：MDBデータインポート
'* 機能　　：MDB(ACCDB)へ初期データインポートを行なう
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2016年12月20日
'* 作成者　：井上　治
'* 更新日　：2019年11月24日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Public Sub MDBデータインポート()
    '-----------------------------------------------------------------------------------------------
    Dim objWsh As WshShell                                          ' WshShell
    Dim dbCon As ADODB.Connection                                   ' ADODB.Connection
    Dim dbCmd As ADODB.Command                                      ' ADODB.Command
    Dim objSh As Worksheet                                          ' Excel.Worksheet
    Dim vntFilename As Variant                                      ' ファイル名(受取)
    Dim strFilename As String                                       ' ファイル名
    Dim strCurrentPathSV As String                                  ' カレントフォルダ(退避)
    '-----------------------------------------------------------------------------------------------
    ' MDB(ACCDB)ファイル名の受け取り
    Set objWsh = New WshShell                                       ' WshShell
    ' 一旦、カレントフォルダを退避
    strCurrentPathSV = objWsh.CurrentDirectory
    ' 本ブックのフォルダをカレントフォルダに設定
    objWsh.CurrentDirectory = ThisWorkbook.Path
    ' ｢開く｣ダイアログでファイル名の受け取り
    vntFilename = Application.GetOpenFilename(g_cnsFilter, , _
                                              "初期データを投入するMDB(ACCDB)ファイルを指定して下さい。")
    ' カレントフォルダの復旧
    objWsh.CurrentDirectory = strCurrentPathSV
    Set objWsh = Nothing
    ' キャンセル確認
    If VarType(vntFilename) = vbBoolean Then Exit Sub
    strFilename = vntFilename
    '-----------------------------------------------------------------------------------------------
    ' MDBに接続
    If Not FP_ConnectMDB(dbCon, strFilename) Then Exit Sub
    ' コマンドを生成
    Set dbCmd = New ADODB.Command
    dbCmd.ActiveConnection = dbCon
    '-----------------------------------------------------------------------------------------------
    ' 本ブックのワークシートを巡回
    For Each objSh In ThisWorkbook.Worksheets
        ' ｢原紙｣シートは除外
        If objSh.Name <> g_cnsSH1 Then
            ' ワークシート単位処理
            If Not FP_WorksheetProc(dbCon, dbCmd, objSh) Then Exit For
        End If
    Next objSh
    ' MDBを切断
    dbCon.Close
    Set dbCmd = Nothing
    Set dbCon = Nothing
End Sub

'***************************************************************************************************
'* 処理名　：FP_WorksheetProc
'* 機能　　：ワークシート単位処理
'---------------------------------------------------------------------------------------------------
'* 返り値　：処理成否(Boolean)
'* 引数　　：Arg1 = ADODB.Connection(Object)
'* 　　　　　Arg2 = ADODB.Command(Object)
'* 　　　　　Arg3 = Excel.Worksheet(Object)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2016年12月20日
'* 作成者　：井上　治
'* 更新日　：2017年01月07日
'* 更新者　：井上　治
'* 機能説明：1つのテーブルに対する初期データの投入
'* 注意事項：先頭でDELETE文を発行しているので以前のデータは全て削除されます
'***************************************************************************************************
Private Function FP_WorksheetProc(ByRef dbCon As ADODB.Connection, _
                                  ByRef dbCmd As ADODB.Command, _
                                  ByRef objSh As Worksheet) As Boolean
    '-----------------------------------------------------------------------------------------------
    Dim lngRow As Long                                              ' 行INDEX
    Dim lngCol As Long                                              ' カラムINDEX
    Dim lngEndRow As Long                                           ' 行INDEX上限
    Dim lngEndCol As Long                                           ' カラムINDEX上限
    Dim strSQL_Base As String                                       ' SQL文共通部
    Dim strSQL As String                                            ' SQL文
    Dim strMSG As String                                            ' メッセージ
    With objSh
        '-------------------------------------------------------------------------------------------
        ' 最終行、最終列の取得
        If .FilterMode Then .ShowAllData
        lngEndRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        lngEndCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        ' データ無しは無視
        If ((lngEndRow <= 2) Or (lngEndCol < 1)) Then
            FP_WorksheetProc = True
            Exit Function
        End If
        '-------------------------------------------------------------------------------------------
        ' Transaction開始
        dbCon.BeginTrans
        '-------------------------------------------------------------------------------------------
        ' DELETE文発行
        strSQL = "DELETE FROM " & FP_EditFieldName(.Name) & ";"
        dbCmd.CommandText = strSQL
        dbCmd.Execute
        '-------------------------------------------------------------------------------------------
        ' INSERT文共通部の編集(シート名をテーブルID、1行目の値をフィールドIDとして編集)
        strSQL_Base = "INSERT INTO " & FP_EditFieldName(.Name) & _
            " (" & FP_EditFieldName(.Cells(1, 1).Value)
        lngCol = 2
        ' 全列を編集
        Do While lngCol <= lngEndCol
            ' フィールド名の編集(共通関数の呼び出し)
            strSQL_Base = strSQL_Base & "," & FP_EditFieldName(.Cells(1, lngCol).Value)
            ' 次の列へ
            lngCol = lngCol + 1
        Loop
        strSQL_Base = strSQL_Base & ") VALUES ("
        On Error GoTo FP_WorksheetProc_ERROR
        ' データの先頭は3行目
        lngRow = 3
        '-------------------------------------------------------------------------------------------
        ' 全行を巡回
        Do While lngRow <= lngEndRow
            ' 先頭項目のフィールド値の編集(共通関数の呼び出し)
            strSQL = strSQL_Base & FP_EditFieldValue(.Cells(lngRow, 1), .Cells(2, 1).Value)
            lngCol = 2
            ' カラムを巡回
            Do While lngCol <= lngEndCol
                ' フィールド値の編集(共通関数の呼び出し)
                strSQL = strSQL & "," & _
                    FP_EditFieldValue(.Cells(lngRow, lngCol), .Cells(2, lngCol).Value)
                ' 次の列へ
                lngCol = lngCol + 1
            Loop
            strSQL = strSQL & ");"
            ' コマンドを発行
            dbCmd.CommandText = strSQL
            dbCmd.Execute
            ' 次の行へ
            lngRow = lngRow + 1
        Loop
        '-------------------------------------------------------------------------------------------
        ' コミット
        dbCon.CommitTrans
        FP_WorksheetProc = True
        On Error GoTo 0
    End With
    Exit Function

'===================================================================================================
' 処理失敗対応
FP_WorksheetProc_ERROR:
    strMSG = "MDBへの更新に失敗しました。" & vbCrLf & Err.Description & vbCrLf & strSQL
    MsgBox strMSG, vbCritical, g_cnsTitle
    ' ロールバック
    On Error Resume Next
    dbCon.RollbackTrans
    FP_WorksheetProc = False
    On Error GoTo 0
End Function

'***************************************************************************************************
'* 処理名　：FP_ConnectMDB
'* 機能　　：MDBへの接続
'---------------------------------------------------------------------------------------------------
'* 返り値　：処理成否(Boolean)
'* 引数　　：Arg1 = ADODB.Connection(Object)
'* 　　　　　Arg2 = MDBファイル名(String)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2016年12月20日
'* 作成者　：井上　治
'* 更新日　：2019年11月24日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Function FP_ConnectMDB(ByRef dbCon As ADODB.Connection, _
                               ByVal strFilename As String) As Boolean
    '-----------------------------------------------------------------------------------------------
    Dim strConnectString As String                                  ' 接続文字列
    Dim strMSG As String                                            ' メッセージ
    ' 接続文字列の編集
    strConnectString = g_cnsADO_Connect1 & strFilename & """;"
    On Error Resume Next
    Set dbCon = New ADODB.Connection
    ' 接続を確立する
    dbCon.Open strConnectString
    ' 接続確認
    If Err.Number <> 0 Then
        strMSG = "MDBへの接続に失敗しました。" & vbCrLf & Err.Description
        MsgBox strMSG, vbCritical, g_cnsTitle
        FP_ConnectMDB = False
    Else
        FP_ConnectMDB = True
    End If
    On Error GoTo 0
End Function

'***************************************************************************************************
'　■■■ 共通サブ処理 ■■■
'***************************************************************************************************
'* 処理名　：FP_EditFieldName
'* 機能　　：フィールド名の編集
'---------------------------------------------------------------------------------------------------
'* 返り値　：編集後文字列(String)
'* 引数　　：Arg1 = 編集前文字列(String)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2016年12月20日
'* 作成者　：井上　治
'* 更新日　：2016年12月20日
'* 更新者　：井上　治
'* 機能説明：Trim及び鍵カッコで囲う
'* 注意事項：
'***************************************************************************************************
Private Function FP_EditFieldName(ByVal strField As String) As String
    '-----------------------------------------------------------------------------------------------
    FP_EditFieldName = "[" & Trim(strField) & "]"
End Function

'***************************************************************************************************
'* 処理名　：FP_EditFieldValue
'* 機能　　：フィールド値の編集
'---------------------------------------------------------------------------------------------------
'* 返り値　：編集後文字列(String)
'* 引数　　：Arg1 = 対象セル(Range)
'* 　　　　　Arg2 = 項目タイプ(Integer)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2016年12月20日
'* 作成者　：井上　治
'* 更新日　：2016年12月20日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Function FP_EditFieldValue(ByRef objR As Range, ByVal intType As Integer) As String
    '-----------------------------------------------------------------------------------------------
    Select Case intType
        Case 0                              ' 文字列
            FP_EditFieldValue = "'" & Trim(objR.Value) & "'"
        Case 1                              ' 整数
            FP_EditFieldValue = "'" & CStr(CLng(objR.Value)) & "'"
        Case 2                              ' 実数
            FP_EditFieldValue = "'" & CStr(CCur(objR.Value)) & "'"
        Case 3                              ' BOOL
            FP_EditFieldValue = "'" & CStr(objR.Value = True) & "'"
        Case 4                              ' 日付
            If objR.Value <> "" Then
                FP_EditFieldValue = "'" & Format(objR.Value, "yyyy-MM-dd") & "'"
            Else
                FP_EditFieldValue = "NULL"
            End If
        Case 5                              ' 時刻
            If objR.Value <> "" Then
                FP_EditFieldValue = "'" & Format(objR.Value, "yyyy-MM-dd HH:mm:ss") & "'"
            Else
                FP_EditFieldValue = "NULL"
            End If
        Case Else                           ' 文章
            FP_EditFieldValue = "'" & Replace(Trim(objR.Value), "'", "''") & "'"
    End Select
End Function

'------------------------------------------<< End of Source >>--------------------------------------