ExcelVBA

Excel VBAでOracle接続し取得したテーブルデータを1シートにまとめて出力してみた

 

これまで、Excel VBAでOracleに接続し、指定したSELECT文のデータを繰り返し取得するプログラムを作成していたが、今回はSELECT文の実行結果を1シートにまとめて出力してみたので、そのサンプルプログラムを共有する。

前提条件

下記記事のサンプルプログラムの作成が完了していること。

Excel VBAで複数テーブルのデータを繰り返し取得するプログラムを作成してみた(ソースコード編)今回も引き続き、複数のテーブルデータを繰り返し取得する処理のサンプルプログラムについて述べる。ここでは、具体的なサンプルプログラムのソー...

また、user_dataテーブル、m_sexテーブルに、以下のデータが作成されていること。
前提条件_1

前提条件_2



サンプルプログラムの作成

今回作成したサンプルプログラムの内容は、以下の通り。

1) サンプルプログラム「DbDump(Oracle).xlsm」のレイアウトは、以下の通り。
サンプルプログラムのレイアウト

2)「取得」ボタンが押下された場合に呼び出されるプログラム「dbDump」サブプロシージャの内容は以下の通りで、SELECT文の実行結果を「DBダンプ(Oracle)」シートにまとめて出力すると共に、changeNullファンクションでNULL値を「(NULL)」と変更している。

Option Explicit  '変数の宣言を必須にする

'-----------------------------------------------------------
' 機能: DBダンプを取得する
' 引数: なし
' 返り値: なし
'-----------------------------------------------------------
Sub dbDump()
    '変数宣言
    Dim ADOConnection As ADODB.Connection
    Dim sSQL As String
    Dim lnSqlIdx As Long
    Dim sWorkSheetName As String
    Dim lnDumpOk As Long
    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
    
    '既にDBダンプ取得後であれば、削除確認ダイアログを表示する
    sWorkSheetName = "DBダンプ(Oracle)"
    Call deleteWorkSheet(sWorkSheetName)
    
    'DBダンプ取得の確認ダイアログを表示する
    lnDumpOk = MsgBox("DBダンプ(Oracle)を取得します。よろしいでしょうか？" _
           , vbYesNo + vbQuestion)
    If lnDumpOk = vbNo Then
        Exit Sub
    End If
    
    'ワークシート「DBダンプ(Oracle)」を追加
    Call addWorkSheet(sWorkSheetName)
    
    '実行SQLに書かれた行数分繰り返す
    For lnSqlIdx = 1 To sqlRowNum

        '実行SQL文を生成
        sSQL = getSQL(lnSqlIdx)
        
        '実行SQLが生成できた場合は、SQLの実行結果を記載
        If sSQL <> "" Then
        
            '指定したワークシートの最終行を取得
            lnLstRow = getLastRow(sWorkSheetName)
        
            'SQL実行結果を記載
            blSqlResult = writeSqlResult(sSQL, sWorkSheetName, lnSqlIdx _
                , lnLstRow + 1, 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ダンプ(Oracle)の取得が完了しました"
    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
    
    'テーブル名が全て空白の場合はエラー
    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
    
    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
    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
    
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 + vbExclamation)
           If lnDelOk = vbYes Then
              Worksheets(sWorkSheetName).Delete
              MsgBox ("ワークシート「" & sWorkSheetName & "」を削除しました。")
           End If
           Application.DisplayAlerts = True
           Exit For
        End If
    Next
    
End Sub

'------------------------------------------------------------------
' 機能: 指定されたシートが何行目まで使用されているかを取得する
'       その際、2行以上空白行が続く直前の行数を取得する
' 引数: sWorkSheetName : シート名
' 返り値: 最終行
'------------------------------------------------------------------
Function getLastRow(sWorkSheetName As String) As Long
   '変数定義
   Dim lnLstRow As Long
   
   '2行以上空白が続く直前の行数を取得
   If Worksheets(sWorkSheetName).Cells(1, 1) = "" _
      And Worksheets(sWorkSheetName).Cells(2, 1) = "" Then
      getLastRow = 0
   Else
      lnLstRow = 1
      Do Until Worksheets(sWorkSheetName).Cells(lnLstRow, 1) = "" _
        And Worksheets(sWorkSheetName).Cells(lnLstRow + 1, 1) = ""
          lnLstRow = lnLstRow + 1
      Loop
      getLastRow = lnLstRow - 1
   End If
   
End Function

'------------------------------------------------------------------
' 機能: 引数で指定したSQL文の実行結果を出力する
' 引数: sSQL           : 実行するSQL行
'       sWorkSheetName : ワークシート名
'       sqlIdx         : 実行SQLのインデックス
'       lnFstRow       : 記載開始行
'       ADOConnection  : DB接続コネクション
' 返り値: 処理結果(True:エラー無、False:エラー有)
'------------------------------------------------------------------
Function writeSqlResult(sSQL As String, sWorkSheetName As String _
      , sqlIdx As Long, lnFstRow As Long, ADOConnection As ADODB.Connection)
   '変数定義
   Dim sTblName As String
   Dim ADORecordset 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
   
   'テーブル名をワークシートに追記
   sTblName = Worksheets("実行情報").Cells(sqlIdx + 11, 4).Value
   Cells(lnFstRow + 1, 1) = "●" & sTblName
   
   'SQL文をワークシートに追記し、セル結合
   Cells(lnFstRow + 2, 1) = "SQL: " & sSQL
   Range(Cells(lnFstRow + 2, 1), Cells(lnFstRow + 2, 10)).Merge
   
   'カラム数を取得
   inFldCnt = ADORecordset.Fields.Count
   
   'カラム名を先頭に表示
   For i = 1 To inFldCnt
      Cells(lnFstRow + 3, i).Value = ADORecordset.Fields(i - 1).Name
      Cells(lnFstRow + 3, i).Interior.Color = RGB(0, 32, 96)
      Cells(lnFstRow + 3, i).Font.Color = RGB(255, 255, 255)
   Next
   
   '先頭レコードからEOFまで繰り返し追記
   lnRowCnt = lnFstRow + 4
   Do Until ADORecordset.EOF
       For i = 1 To inFldCnt
          'カラム値を順に表示
          Cells(lnRowCnt, i) = changeNull(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

'------------------------------------------------------------------
' 機能: 引数の変換前文字列がNULLの場合、(NULL)と変換する
' 引数: sBefore        : 変換前文字列
' 返り値: 変換後文字列
'------------------------------------------------------------------
Function changeNull(sBefore As Variant)
   'NULL値を(NULL)と変換する
   If IsNull(sBefore) Then
      changeNull = "(NULL)"
   Else
      changeNull = sBefore
   End If
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-one-sheet

「EaseUS Todo Backup」は様々な形でバックアップ取得が行える便利ツールだったパソコン内のデータを、ファイル/パーティション/ディスク等の様々な単位でバックアップしたり、バックアップのスケジュール設定や暗号化設定も...

サンプルプログラムの実行結果

今回作成したサンプルプログラムの実行結果は、以下の通り。

1) サンプルプログラム「DbDump(Oracle).xlsm」を開き、下記のように値を入力し「取得」ボタンを押下する。
サンプルプログラムの実行結果_1_1

なお、SIDに入力した「XE」は、以下のように、tnsnames.oraやSQL Developerの接続先から確認できる。
サンプルプログラムの実行結果_1_2

サンプルプログラムの実行結果_1_3

2) 以下のように確認ダイアログが表示されるので、「はい」ボタンを押下する。なお、「いいえ」ボタンを押下した場合は、何もせず処理を終了する。
サンプルプログラムの実行結果_2

3) 取得が完了すると完了メッセージが表示されるため、「OK」ボタンを押下する。
サンプルプログラムの実行結果_3

4) 「DBダンプ(Oracle)」シートを確認すると、以下のように、Select文の実行結果が出力されることが確認できる。なお、NULL値は「(NULL)」と表示されることが確認できる。
サンプルプログラムの実行結果_4

5) 「DBダンプ(Oracle)」シートが存在する状態で「取得」ボタンを押下すると、以下のように、削除確認ダイアログが表示される。削除確認ダイアログで「はい」ボタンを押下すると、「DBダンプ(Oracle)」シートを削除した後で、DBダンプの取得が行われる。
サンプルプログラムの実行結果_5_1

サンプルプログラムの実行結果_5_2

要点まとめ

  • Excel VBAでOracle接続し取得したテーブルデータは、NULL値を別の文字列に変更した上で、1シートにまとめて出力することができる。
RELATED POST