今回も引き続き、複数のテーブルデータを繰り返し取得する処理のサンプルプログラムについて述べる。ここでは、具体的なサンプルプログラムのソースコードを共有する。
前提条件と完成イメージ
下記記事を参照のこと。
Excel VBAで複数テーブルのデータを繰り返し取得するプログラムを作成してみた(完成イメージ編)前回は、Excel VBAでOracleに接続し、指定したSELECT文のデータを取得するプログラムを作成してみたが、今回はそのプログラ...
サンプルプログラムの作成
ファイル「DbDump.xlsm」を開き、実行情報シートを以下のように編集する。
サラリーマン型フリーランスSEという働き方でお金の不安を解消しよう先日、「サラリーマン型フリーランスSE」という働き方を紹介するYouTube動画を視聴しましたので、その内容をご紹介します。 「サ...
また、「取得」ボタンが押下された場合、以下のプログラムの「dbDump」サブプロシージャが呼び出されるようになっている。実行SQLの結果取得をテーブル名が指定された個数分行うようになっている。さらに、同一テーブルの取得結果を同一シートに追記できるようになっている。
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 | Option Explicit '変数の宣言を必須にする '----------------------------------------------------------- ' 機能: DBダンプを取得する ' 引数: なし ' 返り値: なし '----------------------------------------------------------- Sub dbDump() '変数宣言 Dim ADOConnection As ADODB.Connection Dim sSQL As String Dim lnSqlIdx As Long Dim sWorkSheetName As String Dim lnLstRow As Long Dim blSqlResult As Boolean '定数宣言 Const sqlRowNum = 10 '入力チェックを行う If chkInput() = False Then Exit Sub End If 'DBに接続 Set ADOConnection = connectDB() 'DBに接続できなければ、処理を終了 If ADOConnection Is Nothing Then Exit Sub End If '実行SQLに書かれた行数分繰り返す For lnSqlIdx = 1 To sqlRowNum '実行SQL文を生成 sSQL = getSQL(lnSqlIdx) '実行SQLが生成できた場合は、SQLの実行結果を記載 If sSQL <> "" Then 'ワークシート名を取得し、無ければ追加 sWorkSheetName = Worksheets("実行情報").Cells(lnSqlIdx + 11, 4).Value Call addWorkSheet(sWorkSheetName) '指定したワークシートの最終行を取得 lnLstRow = getLastRow(sWorkSheetName) 'SQL実行結果を記載 blSqlResult = writeSqlResult(sSQL, sWorkSheetName , lnLstRow + 2, ADOConnection) 'エラーが発生した場合は、処理を終了 If blSqlResult = False Then Exit For End If End If Next 'DBから切断 Call disConnectDB(ADOConnection) 'SQL実行結果記載処理でエラーがなければ、実行情報シートを 'アクティブにし、完了メッセージを表示 If blSqlResult = True Then Worksheets("実行情報").Activate MsgBox "DBダンプ取得処理が完了しました" End If End Sub '----------------------------------------------------------- ' 機能: 「実行情報」シートの入力チェック処理を行う ' 引数: なし ' 返り値: 処理結果(True:エラー無、False:エラー有) '----------------------------------------------------------- Function chkInput() As Boolean 'SIDが未入力の場合はエラー If Worksheets("実行情報").Cells(5, 3).Value = "" Then MsgBox "SIDを入力してください" chkInput = False Worksheets("実行情報").Cells(5, 3).Select Exit Function End If 'ユーザーIDが未入力の場合はエラー If Worksheets("実行情報").Cells(6, 3).Value = "" Then MsgBox "ユーザーIDを入力してください" chkInput = False Worksheets("実行情報").Cells(6, 3).Select Exit Function End If 'パスワードが未入力の場合はエラー If Worksheets("実行情報").Cells(7, 3).Value = "" Then MsgBox "パスワードを入力してください" chkInput = False Worksheets("実行情報").Cells(7, 3).Select Exit Function End If '取得タイミングが未入力の場合はエラー If Worksheets("実行情報").Cells(5, 7).Value = "" Then MsgBox "取得タイミングを入力してください" chkInput = False Worksheets("実行情報").Cells(5, 7).Select Exit Function End If 'テーブル名が全て空白の場合はエラー Dim rng As Range Set rng = Range("D12", "D21") If WorksheetFunction.CountA(rng) = 0 Then MsgBox "テーブル名が全て未入力です" chkInput = False Worksheets("実行情報").Cells(12, 4).Select Exit Function End If 'テーブル名が空白以外で重複がある場合はエラー Dim lnTblName As Long For lnTblName = 12 To 21 If Cells(lnTblName, 4) <> "" _ And WorksheetFunction.CountIf(Worksheets("実行情報").Range("D12:D21"), _ Worksheets("実行情報").Cells(lnTblName, 4)) > 1 Then MsgBox "テーブル名 " & Worksheets("実行情報").Cells(lnTblName, 4) _ & " が重複しています" chkInput = False Worksheets("実行情報").Cells(lnTblName, 4).Select Exit Function End If Next chkInput = True End Function '----------------------------------------------------------- ' 機能: DB接続を行う ' 引数: なし ' 返り値: DB接続コネクション '----------------------------------------------------------- Function connectDB() As ADODB.Connection '変数定義 Dim sId As String Dim sUser As String Dim sPass As String Dim ADOConnection As ADODB.Connection 'DB接続情報 sId = Worksheets("実行情報").Cells(5, 3).Value 'SID sUser = Worksheets("実行情報").Cells(6, 3).Value 'ユーザーID sPass = Worksheets("実行情報").Cells(7, 3).Value 'パスワード 'DB接続 On Error GoTo ErrOpenDb Set ADOConnection = New ADODB.Connection ADOConnection.ConnectionString = "Provider=OraOLEDB.Oracle;Data Source=" _ & sId & ";User ID=" & sUser & ";Password=" & sPass & ";" ADOConnection.Open Set connectDB = ADOConnection Exit Function ErrOpenDb: 'エラー時は、エラーメッセージを表示 MsgBox "エラーが発生しました" _ & vbCrLf & vbCrLf & Err.Description Set connectDB = Nothing End Function '--------------------------------------------------------------- ' 機能: 実行情報シートの実行SQLで指定された行のSQL文を生成する ' 引数: sqlIdx : 実行SQLのインデックス ' 返り値: 生成されたSQL文 '--------------------------------------------------------------- Function getSQL(sqlIdx As Long) As String '変数定義 Dim sTblName As String Dim sWhere As String 'テーブル名とWhere句を取得 sTblName = Worksheets("実行情報").Cells(sqlIdx + 11, 4).Value sWhere = Worksheets("実行情報").Cells(sqlIdx + 11, 6).Value 'テーブル名が空文字の場合は空文字を返す If sTblName = "" Then getSQL = "" Exit Function End If 'SELECT文を生成 getSQL = "select * from " & sTblName If sWhere <> "" Then getSQL = getSQL & " where " & sWhere End If End Function '---------------------------------------------------------------------- ' 機能: 指定されたシート名のワークシートが無ければ追加する ' 引数: sWorkSheetName : シート名 ' 返り値: なし '---------------------------------------------------------------------- Sub addWorkSheet(sWorkSheetName As String) '変数定義 Dim ws As Worksheet '指定したシートが存在するかどうかチェックし、存在しない場合のみ追加する For Each ws In Sheets If ws.Name = sWorkSheetName Then Exit Sub End If Next Worksheets().Add After:=Worksheets(Worksheets.Count) ActiveSheet.Name = sWorkSheetName ActiveSheet.Cells.Select Selection.NumberFormatLocal = "@" '書式は文字列を指定 Range("A1").Select End Sub '---------------------------------------------------------------------- ' 機能: 指定されたシート名のワークシートを削除する ' 引数: sWorkSheetName : シート名 ' 返り値: なし '---------------------------------------------------------------------- Sub deleteWorkSheet(sWorkSheetName As String) '変数定義 Dim ws As Worksheet Dim lnDelOk As Long '指定したシートが存在するかどうかチェック '指定したシートが存在する場合は、確認ダイアログで確認後削除 For Each ws In Sheets If ws.Name = sWorkSheetName Then Application.DisplayAlerts = False lnDelOk = MsgBox("ワークシート「" & sWorkSheetName _ & "」を削除します。よろしいでしょうか？", vbYesNo) If lnDelOk = vbYes Then Worksheets(sWorkSheetName).Delete End If Application.DisplayAlerts = True Exit For End If Next End Sub '------------------------------------------------------------------ ' 機能: 指定されたシートが何行目まで使用されているかを取得する ' その際、3行以上空白行が続く直前の行数を取得する ' 引数: sWorkSheetName : シート名 ' 返り値: 最終行 '------------------------------------------------------------------ Function getLastRow(sWorkSheetName As String) As Long '変数定義 Dim lnLstRow As Long '3行以上空白が続く直前の行数を取得 If Worksheets(sWorkSheetName).Cells(1, 1) = "" _ And Worksheets(sWorkSheetName).Cells(2, 1) = "" _ And Worksheets(sWorkSheetName).Cells(3, 1) = "" Then getLastRow = 0 Else lnLstRow = 1 Do Until Worksheets(sWorkSheetName).Cells(lnLstRow, 1) = "" _ And Worksheets(sWorkSheetName).Cells(lnLstRow + 1, 1) = "" _ And Worksheets(sWorkSheetName).Cells(lnLstRow + 2, 1) = "" lnLstRow = lnLstRow + 1 Loop getLastRow = lnLstRow - 1 End If End Function '------------------------------------------------------------------ ' 機能: 引数で指定したSQL文の実行結果を出力する ' 引数: sSQL : 実行するSQL行 ' sWorkSheetName : ワークシート名 ' lnFstRow : 記載開始行 ' ADOConnection : DB接続コネクション ' 返り値: 処理結果(True:エラー無、False:エラー有) '------------------------------------------------------------------ Function writeSqlResult(sSQL As String, sWorkSheetName As String _ , lnFstRow As Long, ADOConnection As ADODB.Connection) '変数定義 Dim sEvent As String Dim sInstance As String Dim sUser As String Dim sPassword As String Dim ADORecordset As New ADODB.Recordset Dim myRS As New ADODB.Recordset Dim inFldCnt As Integer Dim lnRowCnt As Long Dim i As Long 'SQLの実行 On Error GoTo ErrExecSelect ADORecordset.Open sSQL, ADOConnection 'アクティブシートをテーブル名のシートに設定 Worksheets(sWorkSheetName).Activate '実行タイミングをワークシートに追記し、セル結合 sEvent = Worksheets("実行情報").Cells(5, 7).Value Cells(lnFstRow, 1) = "【取得タイミング】" & sEvent Range(Cells(lnFstRow, 1), Cells(lnFstRow, 10)).Merge 'SQL文をワークシートに追記し、セル結合 Cells(lnFstRow + 1, 1) = "SQL: " & sSQL Range(Cells(lnFstRow + 1, 1), Cells(lnFstRow + 1, 10)).Merge 'カラム数を取得 inFldCnt = ADORecordset.Fields.Count 'カラム名を先頭に表示 For i = 1 To inFldCnt Cells(lnFstRow + 2, i).Value = ADORecordset.Fields(i - 1).Name Cells(lnFstRow + 2, i).Interior.Color = RGB(0, 32, 96) Cells(lnFstRow + 2, i).Font.Color = RGB(255, 255, 255) Next '先頭レコードからEOFまで繰り返し追記 lnRowCnt = lnFstRow + 3 Do Until ADORecordset.EOF For i = 1 To inFldCnt 'カラム値を順に表示 Cells(lnRowCnt, i) = ADORecordset.Fields(i - 1).Value Cells(lnRowCnt, i).Interior.Color = RGB(221, 235, 247) Next ADORecordset.MoveNext lnRowCnt = lnRowCnt + 1 Loop 'ADORecordsetを閉じる ADORecordset.Close Set ADORecordset = Nothing '列幅を自動調整する Range(Columns(1), Columns(inFldCnt)).EntireColumn.AutoFit Range(Columns(11), Columns(14)).EntireColumn.AutoFit writeSqlResult = True Exit Function ErrExecSelect: 'エラー時は、エラーメッセージを表示 MsgBox "エラーが発生しました" _ & vbCrLf & vbCrLf & Err.Description _ & vbCrLf & vbCrLf & " 実行SQL：" & sSQL '指定したシートを削除 Call deleteWorkSheet(sWorkSheetName) writeSqlResult = False End Function '----------------------------------------------------------- ' 機能: DB切断を行う ' 引数: ADOConnection : DB接続コネクション ' 返り値: なし '----------------------------------------------------------- Sub disConnectDB(ADOConnection As ADODB.Connection) 'DB切断 If Not (ADOConnection Is Nothing) Then ADOConnection.Close Set ADOConnection = Nothing End If End Sub |
その他、実際に作成したVBAファイルの内容は、以下のサイトを参照のこと。
https://github.com/purin-it/vba/tree/master/excel-vba-oracle-muldata-2
要点まとめ
- 複数テーブルのデータを繰り返し取得するプログラムも、ADOというMicrosoftが提唱しているデータアクセス技術を利用すれば作成できる。
