これまで、Excel VBAでOracleに接続し、指定したSELECT文のデータを繰り返し取得するプログラムを作成していたが、今回はそのプログラムを修正し、SELECT文にorder by句が含まれていない場合は、主キーの昇順にソートするようにしてみたので、そのサンプルプログラムを共有する。
前提条件
下記記事のサンプルプログラムの作成が完了していること。
Excel VBAで複数テーブルのデータを繰り返し取得するプログラムを作成してみた(ソースコード編)今回も引き続き、複数のテーブルデータを繰り返し取得する処理のサンプルプログラムについて述べる。ここでは、具体的なサンプルプログラムのソー...
また、user_dataテーブルのデータが以下のように、主キーの昇順にソートした場合とソートしない場合で結果が異なっていること。
サンプルプログラムの作成
修正した「取得」ボタンが押下された場合に呼び出されるプログラム「dbDump」サブプロシージャの内容は以下の通りで、今回追加した「getPrimaryKey」関数で主キー情報を取得し、SQLを生成する「getSQL」関数で、SELECT文にorder by句が含まれていない場合は主キーの昇順にソートするように修正している。
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
Dim primaryKeyList As Object
'定数宣言
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
'主キー情報を取得
Set primaryKeyList = getPrimaryKey(lnSqlIdx, ADOConnection)
'実行SQL文を生成
sSQL = getSQL(lnSqlIdx, primaryKeyList)
'実行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
'-------------------------------------------------------------------
' 機能: 主キー情報を取得する
' 引数: sqlIdx : 実行SQLの指定された行
' ADOConnection : DB接続コネクション
' 返り値: 主キー情報
'-------------------------------------------------------------------
Private Function getPrimaryKey(ByVal sqlIdx As Long, _
ADOConnection As ADODB.Connection) As Object
'変数定義
Dim ADORecordset As New ADODB.Recordset
Dim sTblName As String
Dim tmpPriList As Object '主キー格納用一時リスト
Dim priList As Object '主キー格納用リスト
Dim elem As Variant
'テーブル名を取得し、テーブル名が空文字の場合は空文字を返す
sTblName = Worksheets("実行情報").Cells(11 + sqlIdx, 4).Value
If sTblName = "" Then
Set getPrimaryKey = Nothing
Exit Function
End If
'リストを生成
Set tmpPriList = CreateObject("System.Collections.ArrayList")
Set priList = CreateObject("System.Collections.ArrayList")
'主キー情報を取得するためのADORecordsetを生成
Set ADORecordset = ADOConnection.OpenSchema(adSchemaPrimaryKeys)
'主キー情報をリストに格納し、複合キーの順に並び替える
Do Until ADORecordset.EOF
If ADORecordset("TABLE_NAME").Value = UCase(sTblName) Then
tmpPriList.Add (ADORecordset("ORDINAL").Value & "," _
& ADORecordset("COLUMN_NAME").Value)
Exit Do
End If
ADORecordset.MoveNext
Loop
tmpPriList.Sort
'返却用主キー情報を設定する
For Each elem In tmpPriList
priList.Add (Right(elem, Len(elem) - InStr(elem, ",")))
Next
Set tmpPriList = Nothing
'ADORecordsetを閉じる
ADORecordset.Close
Set ADORecordset = Nothing
Set getPrimaryKey = priList
Set priList = Nothing
End Function
'---------------------------------------------------------------
' 機能: 実行情報シートの実行SQLで指定された行のSQL文を生成する
' 引数: sqlIdx : 実行SQLのインデックス
' primaryKeyList: 主キーリスト
' 返り値: 生成されたSQL文
'---------------------------------------------------------------
Function getSQL(sqlIdx As Long, primaryKeyList As Object) As String
'変数定義
Dim sTblName As String
Dim sWhere As String
Dim elem As Variant
'テーブル名と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
'SELECT文に、order by句が含まれていない場合は、主キー情報によるorder by句を追記
If InStr(Replace(Replace(UCase(getSQL), " ", ""), " ", ""), "ORDERBY") = 0 _
And primaryKeyList.Count > 0 Then
getSQL = getSQL & " order by "
For Each elem In primaryKeyList
getSQL = getSQL & elem
getSQL = getSQL & ", "
Next
getSQL = Left(getSQL, Len(getSQL) - Len(", "))
getSQL = getSQL & " asc"
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-orderby-pkey
サンプルプログラムの実行結果
今回作成したサンプルプログラムの実行結果は、以下の通り。
1) サンプルプログラム「DbDump.xlsm」を開き、下記のように値を入力し「取得」ボタンを押下する。
2) 以下のように完了メッセージが表示されるので、「OK」ボタンを押下
3) 「user_data」シートを確認すると、IDの昇順にデータが出力されることが確認できる。
4) 今回修正前のサンプルプログラムで同じ処理を実行すると、データの取得結果がIDの昇順でないことが確認できる。
要点まとめ
- 主キー情報は、ADOConnectionオブジェクトのOpenSchemaメソッドで、引数adSchemaPrimaryKeysを指定することで、そのレコードセットが取得できる。
