VBA応用(SQLiteで試してみます)

SQLiteはローカル利用に特化した軽量なデータベースです。

前頁のSQLServerと同じ内容のサンプルです。 SQLServerではサーバ側のデータベース環境を用意しなければなりませんでしたが、 SQLiteではMDBと同様でアプリケーションが直接データベースを操作する構造になります。

「データベース」自体はMDBと同様で単一ファイルとなり、今回のサンプルでは起動するExcelワークブックと同じフォルダに作成されます。
SQLiteは高速動作が期待できる軽量型データベースですが、ネットワーク上で利用する用途ではなくローカルPC内で特定アプリ配下で利用すべきものです。ネットワーク型データベースと異なり、ログインユーザー、パスワードといったセキュリティ管理機能は搭載されていません。

事前準備

本サンプルにはSQLiteのODBCドライバが必要になります。 SQLiteはマイクロソフトのプロダクトではないので、他のアプリ等の関連でインストール済みでない限りインストールしていただく必要があります。
「SQLite ODBC Driver」のページより最新バージョンをダウンロードしてインスト－ルさせて下さい。
「sqliteodbc.exe」が32ビット版、「sqliteodbc_w64.exe」が64ビット版となります。
実際はADO接続利用なので、インストールするだけで、コントロールパネルのODBCに関する設定作業は必要ありません。
なお、サンプルの動作確認は32ビット版及び64ビット版で行なっております。

ExcelVBAではなく、直接SQLiteデータベースを操作したい場合は、「DB Browser for SQLite」が手軽に利用いただけます。

SQLiteデータベース作成と初期データ投入

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

ダウンロードして解凍すると下記が作成されます。所望するフォルダに保存させて下さい。

ファイル名	マクロ処理内容
SQLiteインポートデータ(SAMPLE).xlsm	①SQLiteデータベースの作成 ②データベース内に各テーブルの作成 ③各テーブルにExcelワークシートから初期データの登録これらを一括で行ないます。
SQLite配属一覧(SAMPLE).xlsm	各テーブルの登録内容から「配属一覧」を出力します。
SQLite配属登録変更(SAMPLE).xlsm	登録された配属情報から社員を選択して内容の変更(部署又は役職)を行なうサンプルです。

前頁のSQLServerでは「データベース及びテーブル作成」と「初期データ投入」は別のワークブックのマクロからの作業でしたが、本サンプルではデータベース作成～初期データ投入は１つのマクロで行ないます。
ソースコードの内部ではそれぞれの工程が分かれているので必要に応じて確認して下さい。
作成されるSQLiteデータベースは「SQLite3SAMPLE.sqlite3」というファイル名で、マクロを起動するExcelワークブックと同じフォルダに作成されるようになっています。
起動するマクロは「SQLiteインポートデータ(SAMPLE).xlsm」の「SQLite初期データインポート」です。

各マスタデータから「配属一覧」を出力

上記でSQLiteデータベース「SQLite3SAMPLE.sqlite3」が作成されたら、「SQLite配属一覧(SAMPLE).xlsm」を開いて「GetSqliteDataByADO」を起動することで「配属一覧」がシート上に表示されます。
表示内容は前頁のSQLServerと同一です。

参照する主テーブルは「配属マスタ(MST_HAIZOKU)」ですが、このテーブルはコード情報のみで名称情報は収容されていないため、「部署マスタ(MST_BUSYO)」「役職マスタ(MST_YAKU)」「社員マスタ(MST_SYAIN)」をそれぞれ結合させるSQL文を編集し投入してレコードセットを取得しています。

配属情報の登録変更を行なうサンプルも用意しました。

上記でSQLiteデータベース「SQLite3SAMPLE.sqlite3」が作成されたら、「SQLite配属登録変更(SAMPLE).xlsm」を開くと、「配属一覧」がシート上に表示されます。
この「配属一覧」上で変更を行なう社員の行を選択すると、この画面のように「配属情報の登録・変更」フォームが表示され、部署又は役職の変更が行なえるというサンプルです。
このサンプルは「Excelでデータベースを更新する。」のMDB(ACCDB)のサンプルを単純に移植したものです。 SQLiteデータベースへの接続プロシージャ「FP_ConnectSQLite」はこの前の「配属一覧」のものをそのまま利用しており、動作確認でエラーとなったSQL文の一部修正のみでそのまま動いています。

このため、本ページ内ではソースコードの紹介は省略させていただいております。ソースコードはダウンロードしたサンプルでご覧いただけます。

それではソースコードの紹介です。

まずは「SQLiteインポートデータ(SAMPLE).xlsm」のモジュールです。


'***************************************************************************************************
'   SQLite初期データインポートツール                        modSQLite1(Module)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'   [概要説明]
'　 ・本ブックのフォルダに｢SQLite3SAMPLE.sqlite3｣がデータベースファイルとして作成されます
'　 　フォルダにデータベースファイルが存在しない場合は新規作成された上で各テーブルが作成されます
'　 　フォルダにデータベースファイルが存在する場合は各テーブルが再作成されます
'***************************************************************************************************
'   [参照設定]
'   ・Microsoft Active Data Objects 2.x Library
'   ・Microsoft Scripting Runtime
'   ※利用PCにSQLite3 ODBC Driverのインストールが必要です
'***************************************************************************************************
' 変更日付 Rev   変更履歴内容---------------------------------------------------------------------->
' 21/07/22(1.0.0)新規作成
'***************************************************************************************************
Option Explicit
'===================================================================================================
Private Const g_cnsTitle = "SQLite初期データインポート"
'---------------------------------------------------------------------------------------------------
Private Const g_cnsDBName = "SQLite3SAMPLE.sqlite3"
Private Const g_cnsAdoSQLiteConnect1 = "DRIVER=SQLite3 ODBC Driver;Database="
Private Const g_cnsSh1 = "原紙"
Private Const g_cnsCol = ";"
Private Const g_cnsSc = "'"
Private Const g_cnsCom = ","

'***************************************************************************************************
'　■■■ 外部からの呼び出し処理(Public) ■■■
'***************************************************************************************************
'* 処理名　：SQLite初期データインポート
'* 機能　　：SQLiteデータベースへ初期データインポートを行なう
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2021年07月22日
'* 作成者　：井上　治
'* 更新日　：2021年07月22日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Public Sub SQLite初期データインポート()
    '-----------------------------------------------------------------------------------------------
    Dim dbCon As ADODB.Connection                                   ' ADODB.Connection
    Dim dbCmd As ADODB.Command                                      ' ADODB.Command
    Dim objSh As Worksheet                                          ' Excel.Worksheet
    Dim blnSuccess As Boolean                                       ' 処理成否
    Dim strMsg As String                                            ' メッセージWork
    Dim strMsgBase As String                                        ' メッセージベース
    '-----------------------------------------------------------------------------------------------
    blnSuccess = False
    ' SQLiteに接続
    If Not FP_ConnectSQLite(dbCon, dbCmd) Then Exit Sub
    '-----------------------------------------------------------------------------------------------
    On Error GoTo ImportData_ERROR
    Application.StatusBar = "初期データインポート中．．．．"
    ' 本ブックのワークシートを巡回
    For Each objSh In ThisWorkbook.Worksheets
        ' ｢原紙｣シートは除外
        If objSh.Name <> g_cnsSh1 Then
            strMsgBase = "「" & objSh.Name & "」のデータインポートに失敗しました。"
            ' 初期データインポート
            Call GP_ImportInitData(dbCon, dbCmd, objSh)
        End If
    Next objSh
    ' インポート成功！
    blnSuccess = True
    GoTo ImportData_EXIT

'===================================================================================================
' エラー
ImportData_ERROR:
    strMsg = strMsgBase & vbCr & Err.Description
    MsgBox strMsg, vbCritical, g_cnsTitle
    ' ロールバック
    On Error Resume Next
    dbCon.RollbackTrans

'===================================================================================================
' 終了
ImportData_EXIT:
    Set dbCmd = Nothing
    dbCon.Close
    Set dbCon = Nothing
    Application.StatusBar = False
    On Error GoTo 0
    ' 成功？
    If blnSuccess Then
        MsgBox "初期データインポートは成功しました。", vbInformation, g_cnsTitle
    End If
End Sub

'***************************************************************************************************
'　■■■ サブ処理(Private) ■■■
'***************************************************************************************************
'* 処理名　：FP_ConnectSQLite
'* 機能　　：SQLiteへの接続
'---------------------------------------------------------------------------------------------------
'* 返り値　：処理成否(Boolean)
'* 引数　　：Arg1 = ADODB.Connection(Object)            ※Ref参照
'* 　　　　　Arg2 = ADODB.Command(Object)               ※Ref参照
'---------------------------------------------------------------------------------------------------
'* 作成日　：2021年07月22日
'* 作成者　：井上　治
'* 更新日　：2021年07月22日
'* 更新者　：井上　治
'* 機能説明：SQLiteデータベースに接続し各テーブルを作成(作成部分は内部呼び出しの別処理)
'* 注意事項：
'***************************************************************************************************
Private Function FP_ConnectSQLite(ByRef dbCon As ADODB.Connection, _
                                  ByRef dbCmd As ADODB.Command) As Boolean
    '-----------------------------------------------------------------------------------------------
    Dim objFso As FileSystemObject                                  ' FileSystemObject
    Dim objSh As Worksheet                                          ' Excel.Worksheet
    Dim blnDbExists As Boolean                                      ' DBファイル存在有無
    Dim strDbFullname As String                                     ' DBフルパス名
    Dim strConnectString As String                                  ' 接続文字列
    Dim strMsg As String                                            ' メッセージWork
    Dim strMsgBase As String                                        ' メッセージベース
    '-----------------------------------------------------------------------------------------------
    FP_ConnectSQLite = False
    Application.StatusBar = g_cnsDBName & " 接続中．．．．"
    On Error GoTo ConnectSQLite_ERROR
    Set objFso = New FileSystemObject
    strMsgBase = "DBファイルの参照に失敗しました。"
    ' DBフルパス名の編集
    strDbFullname = objFso.BuildPath(ThisWorkbook.Path, g_cnsDBName)
    ' DBファイル存在有無確認
    blnDbExists = objFso.FileExists(strDbFullname)
    '-----------------------------------------------------------------------------------------------
    ' DBファイル存在時再作成確認
    If blnDbExists Then
        strMsg = "本フォルダに「" & g_cnsDBName & "」が存在します。" & vbCr & _
                 "再作成してよろしいですか？"
        ' 確認NGは終了
        If MsgBox(strMsg, vbInformation + vbYesNo, g_cnsTitle) <> vbYes Then
            GoTo ConnectSQLite_EXIT
        Else
            ' 一旦削除
            strMsgBase = "DBファイルの事前削除に失敗しました。"
            objFso.DeleteFile strDbFullname, True
        End If
    End If
    '-----------------------------------------------------------------------------------------------
    ' 接続文字列の編集
    strConnectString = g_cnsAdoSQLiteConnect1 & strDbFullname & g_cnsCol
    strMsgBase = "SQLiteデータベースへの接続に失敗しました。"
    Set dbCon = New ADODB.Connection
    ' 接続を確立する
    dbCon.Open strConnectString
    ' コマンドを生成
    Set dbCmd = New ADODB.Command
    dbCmd.ActiveConnection = dbCon
    '-----------------------------------------------------------------------------------------------
    Application.StatusBar = "テーブル作成中．．．．"
    ' 本ブックのワークシートを巡回
    For Each objSh In ThisWorkbook.Worksheets
        ' ｢原紙｣シートは除外
        If objSh.Name <> g_cnsSh1 Then
            strMsgBase = "SQLiteテーブル(" & objSh.Name & ")の作成に失敗しました。"
            ' テーブル作成
            Call GP_CreateTable(dbCmd, objSh)
        End If
    Next objSh
    FP_ConnectSQLite = True
    GoTo ConnectSQLite_EXIT

'===================================================================================================
' エラー
ConnectSQLite_ERROR:
    strMsg = strMsgBase & vbCr & Err.Description
    MsgBox strMsg, vbCritical, g_cnsTitle
    Set dbCmd = Nothing

'===================================================================================================
' 終了
ConnectSQLite_EXIT:
    Set objFso = Nothing
    Application.StatusBar = False
    On Error GoTo 0
End Function

'***************************************************************************************************
'* 処理名　：GP_CreateTable
'* 機能　　：テーブル作成
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：Arg1 = ADODB.Command(Object)
'* 　　　　　Arg2 = Excel.Worksheet(Object)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2021年07月22日
'* 作成者　：井上　治
'* 更新日　：2021年07月22日
'* 更新者　：井上　治
'* 機能説明：ワークシートの見出し情報からテーブルを作成する
'* 注意事項：エラー処理は上位で行なう前提
'***************************************************************************************************
Private Sub GP_CreateTable(ByVal dbCmd As ADODB.Command, ByVal objSh As Worksheet)
    '-----------------------------------------------------------------------------------------------
    Dim lngCol As Long                                              ' カラムINDEX
    Dim lngEndCol As Long                                           ' カラムINDEX上限
    Dim strSQL As String                                            ' SQL文
    With objSh
        '-------------------------------------------------------------------------------------------
        lngEndCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        ' データ無しは無視
        If lngEndCol < 1 Then Exit Sub
        strSQL = "CREATE TABLE " & FP_EditColName(.Name) & " (" & FP_EditColInfo(objSh, 1)
        lngCol = 2
        ' 各カラムを追記
        Do While lngCol <= lngEndCol
            strSQL = strSQL & g_cnsCom & FP_EditColInfo(objSh, lngCol)
            ' 次のカラムへ
            lngCol = lngCol + 1
        Loop
        ' プライマリーキー(配属マスタのみ社員コード＋開始日)
        strSQL = strSQL & ", PRIMARY KEY ("
        Select Case .Name
            Case "MST_HAIZOKU"
                strSQL = strSQL & FP_EditColName(.Cells(1, 1).Value)
                strSQL = strSQL & g_cnsCom & FP_EditColName(.Cells(1, 2).Value)
            Case Else
                strSQL = strSQL & FP_EditColName(.Cells(1, 1).Value)
        End Select
        ' 重複不可(配属マスタのみ社員コード＋開始日)
        strSQL = strSQL & "), UNIQUE ("
        Select Case .Name
            Case "MST_HAIZOKU"
                strSQL = strSQL & FP_EditColName(.Cells(1, 1).Value)
                strSQL = strSQL & g_cnsCom & FP_EditColName(.Cells(1, 2).Value)
            Case Else
                strSQL = strSQL & FP_EditColName(.Cells(1, 1).Value)
        End Select
        strSQL = strSQL & "));"
    End With
    ' コマンド発行
    dbCmd.CommandText = strSQL
    dbCmd.Execute
End Sub

'***************************************************************************************************
'* 処理名　：GP_ImportInitData
'* 機能　　：初期データインポート
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：Arg1 = ADODB.Connection(Object)
'* 　　　　　Arg2 = ADODB.Command(Object)
'* 　　　　　Arg3 = Excel.Worksheet(Object)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2021年07月22日
'* 作成者　：井上　治
'* 更新日　：2021年07月22日
'* 更新者　：井上　治
'* 機能説明：ワークシート上のデータをSQLiteデータベーステーブルに登録(1テーブル分)
'* 注意事項：エラー処理は上位で行なう前提
'***************************************************************************************************
Private Sub GP_ImportInitData(ByRef dbCon As ADODB.Connection, _
                              ByRef dbCmd As ADODB.Command, _
                              ByRef objSh As Worksheet)
    '-----------------------------------------------------------------------------------------------
    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文
    With objSh
        '-------------------------------------------------------------------------------------------
        Application.StatusBar = .Name & " インポート中．．．．"
        ' 最終行、最終列の取得
        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 Exit Sub
        '-------------------------------------------------------------------------------------------
        ' Transaction開始
        dbCon.BeginTrans
        '-------------------------------------------------------------------------------------------
        ' INSERT文共通部の編集(シート名をテーブルID、1行目の値をフィールドIDとして編集)
        strSQL_Base = "INSERT INTO " & FP_EditColName(.Name) & " (" & FP_EditColName(.Cells(1, 1).Value)
        lngCol = 2
        ' 全列を編集
        Do While lngCol <= lngEndCol
            ' フィールド名の編集(共通関数の呼び出し)
            strSQL_Base = strSQL_Base & g_cnsCom & FP_EditColName(.Cells(1, lngCol).Value)
            ' 次の列へ
            lngCol = lngCol + 1
        Loop
        strSQL_Base = strSQL_Base & ") VALUES ("
        ' データの先頭は3行目
        lngRow = 3
        '-------------------------------------------------------------------------------------------
        ' 全行を巡回
        Do While lngRow <= lngEndRow
            ' 先頭項目のフィールド値の編集(共通関数の呼び出し)
            strSQL = strSQL_Base & FP_EditFieldValue(objSh, lngRow, 1)
            lngCol = 2
            ' カラムを巡回
            Do While lngCol <= lngEndCol
                ' フィールド値の編集(共通関数の呼び出し)
                strSQL = strSQL & g_cnsCom & FP_EditFieldValue(objSh, lngRow, lngCol)
                ' 次の列へ
                lngCol = lngCol + 1
            Loop
            strSQL = strSQL & ");"
            ' コマンドを発行
            dbCmd.CommandText = strSQL
            dbCmd.Execute
            ' 次の行へ
            lngRow = lngRow + 1
        Loop
        '-------------------------------------------------------------------------------------------
        ' コミット
        dbCon.CommitTrans
    End With
End Sub

'***************************************************************************************************
'　■■■ 共通サブ処理 ■■■
'***************************************************************************************************
'* 処理名　：FP_EditColInfo
'* 機能　　：カラム情報の編集(テーブル作成時用)
'---------------------------------------------------------------------------------------------------
'* 返り値　：編集後文字列(String)
'* 引数　　：Arg1 = Excel.Worksheet(Object)
'* 　　　　　Arg2 = 列INDEX(Long)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2021年07月22日
'* 作成者　：井上　治
'* 更新日　：2021年07月22日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：日付・時刻以外はNOT NULL固定
'***************************************************************************************************
Private Function FP_EditColInfo(ByVal objSh As Worksheet, ByVal lngCol As Long) As String
    '-----------------------------------------------------------------------------------------------
    Dim intType As Integer                                          ' カラムタイプ
    Dim strColinfo As String                                        ' カラム名
    With objSh
        intType = .Cells(2, lngCol).Value
        strColinfo = FP_EditColName(.Cells(1, lngCol).Value)
        Select Case intType
            Case 1                                  ' 整数
                strColinfo = strColinfo & " integer NOT NULL"
            Case 2                                  ' 実数
                strColinfo = strColinfo & " real NOT NULL"
            Case 3                                  ' BOOL
                strColinfo = strColinfo & " bit NOT NULL"
            Case 4, 5                               ' 日付・時刻
                strColinfo = strColinfo & " datetime NULL"
            Case Else                               ' 文字列
                strColinfo = strColinfo & " text NOT NULL"
        End Select
        FP_EditColInfo = strColinfo
    End With
End Function

'***************************************************************************************************
'* 処理名　：FP_EditFieldValue
'* 機能　　：フィールド値の編集
'---------------------------------------------------------------------------------------------------
'* 返り値　：編集後文字列(String)
'* 引数　　：Arg1 = Excel.Worksheet(Object)
'* 　　　　　Arg2 = 行INDEX(Long)
'* 　　　　　Arg3 = 列INDEX(Long)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2021年07月22日
'* 作成者　：井上　治
'* 更新日　：2021年07月22日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Function FP_EditFieldValue(ByVal objSh As Worksheet, _
                                   ByVal lngRow As Long, _
                                   ByVal lngCol As Long) As String
    '-----------------------------------------------------------------------------------------------
    Dim objR As Range                                               ' Range
    With objSh
        Set objR = .Cells(lngRow, lngCol)
        Select Case .Cells(2, lngCol).Value
            Case 0                              ' 文字列
                FP_EditFieldValue = g_cnsSc & Trim(objR.Value) & g_cnsSc
            Case 1                              ' 整数
                FP_EditFieldValue = g_cnsSc & CStr(CLng(objR.Value)) & g_cnsSc
            Case 2                              ' 実数
                FP_EditFieldValue = g_cnsSc & CStr(CCur(objR.Value)) & g_cnsSc
            Case 3                              ' BOOL
                FP_EditFieldValue = g_cnsSc & CStr(objR.Value = True) & g_cnsSc
            Case 4                              ' 日付
                If objR.Value <> "" Then
                    FP_EditFieldValue = g_cnsSc & Format(objR.Value, "yyyy-MM-dd") & g_cnsSc
                Else
                    FP_EditFieldValue = "NULL"
                End If
            Case 5                              ' 時刻
                If objR.Value <> "" Then
                    FP_EditFieldValue = g_cnsSc & Format(objR.Value, "yyyy-MM-dd HH:mm:ss") & g_cnsSc
                Else
                    FP_EditFieldValue = "NULL"
                End If
            Case Else                           ' 文章
                FP_EditFieldValue = g_cnsSc & Replace(Trim(objR.Value), g_cnsSc, "''") & g_cnsSc
        End Select
    End With
End Function

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

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

データベース作成におけるSQLiteは「CreateDatabase」といった構文を用いずに、データベースに接続する動作だけでデータベースファイルが作成されます。フルパスファイル名で指定されたデータベースファイルが既に存在する場合はそのデータベースファイルに接続されるという仕組みです。

このサンプルでは「データベースファイル作成＋初期データ投入」となっているため、データベースファイルが既に存在する場合は確認の上で「再作成」という動作としています。

次は「配属一覧作成」のモジュールです。


'***************************************************************************************************
'   ADOでSQLiteデータベースからデータをシート上に展開する       modSQLite2(Module)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'   [参照設定]
'   ・Microsoft Active Data Object 2.x Library(2.8 or Later)
'   ・Microsoft Scripting Runtime
'   ※利用PCにSQLite3 ODBC Driverのインストールが必要です
'***************************************************************************************************
' 変更日付 Rev   変更履歴内容---------------------------------------------------------------------->
' 21/07/22(1.0.0)新規作成
'***************************************************************************************************
Option Explicit
Private Const g_cnsTitle = "ADOによるSQLiteデータ取得"
'---------------------------------------------------------------------------------------------------
Private Const g_cnsDBName = "SQLite3SAMPLE.sqlite3"
Private Const g_cnsAdoSQLiteConnect1 = "DRIVER=SQLite3 ODBC Driver;Database="
Private Const g_cnsCol = ";"
Private Const g_cnsSc = "'"

'***************************************************************************************************
'　■■■ 外部からの呼び出し処理(Public) ■■■
'***************************************************************************************************
'* 処理名　：GetSqliteDataByADO
'* 機能　　：ADOによるデータ取得
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2021年07月22日
'* 作成者　：井上　治
'* 更新日　：2021年07月22日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Public Sub GetSqliteDataByADO()
    '-----------------------------------------------------------------------------------------------
    Dim dbCon As ADODB.Connection                                   ' ADODB.Connection
    Dim dbRes As ADODB.Recordset                                    ' ADODB.Recordset
    Dim objSh As Worksheet                                          ' Excel.Worksheet
    Dim strSQL As String                                            ' SQL文編集WORK
    Dim strToday As String                                          ' SQL文本日編集WORK
    Dim lngRow As Long                                              ' 行INDEX
    Dim lngCol As Long                                              ' 列INDEX
    Dim lngIx As Long                                               ' テーブルINDEX
    Dim strMsg As String                                            ' メッセージWork
    Dim strMsgBase As String                                        ' メッセージベース
    '-----------------------------------------------------------------------------------------------
    ' SQLServerに接続
    If Not FP_ConnectSQLite(dbCon) Then Exit Sub
    On Error GoTo GetSqliteDataByADO_ERROR
    '-----------------------------------------------------------------------------------------------
    ' 参照SQL文の編集
    strToday = g_cnsSc & Format(Date, "yyyy-MM-dd") & g_cnsSc
    strSQL = "SELECT H.[BUSYO_CD]"                                  ' (00)部署コード
    strSQL = strSQL & ",B.[BUSYO_NM]"                               ' (01)部署名
    strSQL = strSQL & ",H.[YAKU_CD]"                                ' (02)役職コード
    strSQL = strSQL & ",Y.[YAKU_NM]"                                ' (03)役職名
    strSQL = strSQL & ",H.[SCD]"                                    ' (04)社員コード
    strSQL = strSQL & ",S.[KANJI_SEI]||S.[KANJI_MEI]"               ' (05)氏名(漢字)
    strSQL = strSQL & ",S.[KANA_SEI]||S.[KANA_MEI]"                 ' (06)氏名(カナ)
    strSQL = strSQL & ",S.[NYUSYA_YMD]"                             ' (07)入社日
    strSQL = strSQL & ",S.[TAISYOKU_YMD]"                           ' (08)退職日
    strSQL = strSQL & " FROM [MST_HAIZOKU] AS H"
    strSQL = strSQL & " INNER JOIN [MST_SYAIN] AS S"
    strSQL = strSQL & " ON (H.[SCD]=S.[SCD])"
    strSQL = strSQL & " LEFT OUTER JOIN [MST_BUSYO] AS B"
    strSQL = strSQL & " ON (H.[BUSYO_CD]=B.[BUSYO_CD])"
    strSQL = strSQL & " LEFT OUTER JOIN [MST_YAKU] AS Y"
    strSQL = strSQL & " ON (H.[YAKU_CD]=Y.[YAKU_CD])"
    strSQL = strSQL & " WHERE S.[NYUSYA_YMD]<=" & strToday
    strSQL = strSQL & " AND (S.[TAISYOKU_YMD] IS NULL OR S.[TAISYOKU_YMD]>" & strToday & ")"
    strSQL = strSQL & " ORDER BY H.[BUSYO_CD],H.[YAKU_CD],H.[SCD];"
    ' 参照SQL文の発行
    Set dbRes = New ADODB.Recordset
    dbRes.Open strSQL, dbCon, adOpenKeyset, adLockReadOnly
    ' 画面描画更新停止
    Call GP_StopScreen
    '-----------------------------------------------------------------------------------------------
    ' シート初期化
    Set objSh = ThisWorkbook.Worksheets(1)
    With objSh
        If .FilterMode Then .ShowAllData
        .Rows("2:" & .Rows.Count).ClearContents
        lngRow = 1
        ' 先頭レコードからEOFまで繰り返す
        Do Until dbRes.EOF
            ' 行を加算
            lngRow = lngRow + 1
            ' 全列をシートに展開
            For lngIx = 0 To 8
                lngCol = lngIx + 1
                .Cells(lngRow, lngCol).Value = dbRes.Fields(lngIx).Value
            Next lngIx
            ' 次のレコードに移る
            dbRes.MoveNext
        Loop
    End With
    GoTo GetSqliteDataByADO_EXIT

'===================================================================================================
' エラー
GetSqliteDataByADO_ERROR:
    Application.ScreenUpdating = True
    strMsg = strMsgBase & vbCr & Err.Description
    MsgBox strMsg, vbCritical, g_cnsTitle

'===================================================================================================
' 終了
GetSqliteDataByADO_EXIT:
    ' レコードセット、データベースを閉じる
    On Error Resume Next
    dbRes.Close
    Set dbRes = Nothing
    dbCon.Close
    Set dbCon = Nothing
    On Error GoTo 0
    ' 画面描画更新復帰
    Call GP_StartScreen
    ThisWorkbook.Saved = True
End Sub

'***************************************************************************************************
'　■■■ サブ処理(Private) ■■■
'***************************************************************************************************
'* 処理名　：FP_ConnectSQLite
'* 機能　　：SQLiteへの接続
'---------------------------------------------------------------------------------------------------
'* 返り値　：処理成否(Boolean)
'* 引数　　：Arg1 = ADODB.Connection(Object)            ※Ref参照
'---------------------------------------------------------------------------------------------------
'* 作成日　：2021年07月22日
'* 作成者　：井上　治
'* 更新日　：2021年07月22日
'* 更新者　：井上　治
'* 機能説明：SQLiteデータベースに接続(場所は本ブックのフォルダ)
'* 注意事項：
'***************************************************************************************************
Private Function FP_ConnectSQLite(ByRef dbCon As ADODB.Connection) As Boolean
    '-----------------------------------------------------------------------------------------------
    Dim objFso As FileSystemObject                                  ' FileSystemObject
    Dim strDbFullname As String                                     ' DBフルパス名
    Dim strConnectString As String                                  ' 接続文字列
    Dim strMsg As String                                            ' メッセージWork
    Dim strMsgBase As String                                        ' メッセージベース
    '-----------------------------------------------------------------------------------------------
    FP_ConnectSQLite = False
    Application.StatusBar = g_cnsDBName & " 接続中．．．．"
    On Error GoTo ConnectSQLite_ERROR
    Set objFso = New FileSystemObject
    strMsgBase = "DBファイルの参照に失敗しました。"
    ' DBフルパス名の編集
    strDbFullname = objFso.BuildPath(ThisWorkbook.Path, g_cnsDBName)
    ' DBファイル存在確認(存在必須)
    If Not objFso.FileExists(strDbFullname) Then
        strMsg = "「" & g_cnsDBName & "」が見つかりません。(本ブックのフォルダ)"
        MsgBox strMsg, vbCritical, g_cnsTitle
        GoTo ConnectSQLite_EXIT
    End If
    '-----------------------------------------------------------------------------------------------
    ' 接続文字列の編集
    strConnectString = g_cnsAdoSQLiteConnect1 & strDbFullname & g_cnsCol
    strMsgBase = "SQLiteデータベースへの接続に失敗しました。"
    Set dbCon = New ADODB.Connection
    ' 接続を確立する
    dbCon.Open strConnectString
    ' クライアントカーソル設定(adUseServerがデフォルト)
    dbCon.CursorLocation = adUseClient
    ' 接続成功
    FP_ConnectSQLite = True
    GoTo ConnectSQLite_EXIT

'===================================================================================================
' エラー
ConnectSQLite_ERROR:
    strMsg = strMsgBase & vbCr & Err.Description
    MsgBox strMsg, vbCritical, g_cnsTitle

'===================================================================================================
' 終了
ConnectSQLite_EXIT:
    Set objFso = Nothing
    Application.StatusBar = False
    On Error GoTo 0
End Function

'***************************************************************************************************
'* 処理名　：GP_StopScreen
'* 機能　　：画面描画停止
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：Arg1 = ガイドメッセージ(String)            ※Option
'* 　　　　　Arg2 = マウスカーソル制御(Boolean)         ※Option
'---------------------------------------------------------------------------------------------------
'* 作成日　：2021年07月22日
'* 作成者　：井上　治
'* 更新日　：2021年07月22日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub GP_StopScreen(Optional ByVal strGUIDE As String = "", _
                          Optional ByVal swWait As Boolean = False)
    '-----------------------------------------------------------------------------------------------
    With Application
        .ScreenUpdating = False                         ' 画面描画停止
        .Calculation = xlCalculationManual              ' 自動計算停止
        If strGUIDE <> "" Then .StatusBar = strGUIDE    ' ステータスバー
        If swWait <> True Then .Cursor = xlWait         ' マウスカーソル(砂時計)
        .EnableEvents = False                           ' イベントを抑制
'        .EnableCancelKey = xlDisabled                   ' Escキー無効
    End With
End Sub

'***************************************************************************************************
'* 処理名　：GP_StartScreen
'* 機能　　：画面描画再開
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：Arg1 = ガイドメッセージ(String)            ※Option
'---------------------------------------------------------------------------------------------------
'* 作成日　：2021年07月22日
'* 作成者　：井上　治
'* 更新日　：2021年07月22日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub GP_StartScreen(Optional ByVal strGUIDE As String = "")
    '-----------------------------------------------------------------------------------------------
    With Application
'        .EnableCancelKey = xlInterrupt                  ' Escキー無効解除
        If .Calculation <> xlCalculationAutomatic Then
            .Calculation = xlCalculationAutomatic       ' 自動計算開始
        End If
        .Cursor = xlDefault                             ' マウスカーソル(標準)
        If strGUIDE <> "" Then
            .StatusBar = strGUIDE                       ' ステータスバー
        Else
            .StatusBar = False
        End If
        .EnableEvents = True                            ' イベント抑制解除
        .ScreenUpdating = True                          ' 画面描画復旧
    End With
End Sub

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

こちらはデータベースファイルが作成されていることが前提となるため、データベースファイルが存在しない場合はエラーとしています。
データベース接続部分以外は前頁のSQLServerとあまり変わりませんが、

編集されるSQL文については以下のようになります。


SELECT H.[BUSYO_CD]
      ,B.[BUSYO_NM]
      ,H.[YAKU_CD]
      ,Y.[YAKU_NM]
      ,H.[SCD]
      ,S.[KANJI_SEI]||S.[KANJI_MEI]
      ,S.[KANA_SEI]||S.[KANA_MEI]
      ,S.[NYUSYA_YMD]
      ,S.[TAISYOKU_YMD]
FROM [MST_HAIZOKU] AS H
INNER JOIN [MST_SYAIN] AS S ON (H.[SCD]=S.[SCD])
LEFT OUTER JOIN [MST_BUSYO] AS B ON (H.[BUSYO_CD]=B.[BUSYO_CD])
LEFT OUTER JOIN [MST_YAKU] AS Y ON (H.[YAKU_CD]=Y.[YAKU_CD])
WHERE S.[NYUSYA_YMD]<='2021-07-21'
 AND (S.[TAISYOKU_YMD] IS NULL OR S.[TAISYOKU_YMD]>'2021-07-21')
ORDER BY H.[BUSYO_CD],H.[YAKU_CD],H.[SCD];

前頁のSQLServerとの違いとしては、姓名接合の演算子が「+」から「||」に変わっている程度です。

SQLiteで試してみます。

SQLiteはローカル利用に特化した軽量なデータベースです。