Excelから取得した接続情報をAccess 連携

'//Access側のvba code

Function GetOracleConnectionString(dsn As String, uid As String, pwd As String) As String
    Dim connStr As String
    connStr = "ODBC;DSN=" & dsn & ";UID=" & uid & ";PWD=" & pwd
    GetOracleConnectionString = connStr
End Function

'//Excel側ののvba code

Sub FetchDataUsingAccessVBA()
    Dim accessApp As Object
    Dim dbPath As String
    Dim connStr As String
    Dim conn As Object
    Dim rs As Object
    Dim sqlStr As String
    Dim ws As Worksheet
    Dim rowIndex As Integer
    Dim colIndex As Integer
    Dim dsn As String
    Dim uid As String
    Dim pwd As String
    
    On Error GoTo ErrorHandler
    
    ' Accessデータベースのパスを指定
    dbPath = "D:\サンプルData.accdb"
    
    ' データを出力するExcelのシートを指定
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    ' ODBC接続情報をExcelのSheet2から取得
    With ThisWorkbook.Sheets("Sheet2")
        dsn = .Range("A1").Value
        uid = .Range("A2").Value
        pwd = .Range("A3").Value
    End With
    
    ' Accessアプリケーションを起動
    Set accessApp = CreateObject("Access.Application")
    
    ' Accessデータベースを開く
    accessApp.OpenCurrentDatabase dbPath
    
    ' AccessからOracleの接続文字列を取得
    connStr = accessApp.Run("GetOracleConnectionString", dsn, uid, pwd)
    
    ' ADODB.Connectionオブジェクトを作成し、Oracleに接続
    Set conn = CreateObject("ADODB.Connection")
    conn.Open connStr
    
    ' 実行するSQLクエリを設定（実際のクエリに変更）
    sqlStr = "SELECT * FROM YourTable"
    
    ' ADODB.Recordsetオブジェクトを作成し、SQLクエリを実行
    Set rs = CreateObject("ADODB.Recordset")
    rs.Open sqlStr, conn
    
    ' フィールド名をExcelの1行目にヘッダーとして書き込み
    For colIndex = 0 To rs.Fields.Count - 1
        ws.Cells(1, colIndex + 1).Value = rs.Fields(colIndex).Name
    Next colIndex
    
    ' データをExcelに書き込み
    rowIndex = 2 ' データ書き込み開始行
    Do While Not rs.EOF
        For colIndex = 0 To rs.Fields.Count - 1
            ws.Cells(rowIndex, colIndex + 1).Value = rs.Fields(colIndex).Value
        Next colIndex
        rs.MoveNext
        rowIndex = rowIndex + 1
    Loop
    
    ' クリーンアップ
    rs.Close
    conn.Close
    Set rs = Nothing
    Set conn = Nothing
    
    ' Accessアプリケーションを閉じる
    accessApp.CloseCurrentDatabase
    accessApp.Quit
    Set accessApp = Nothing
    
    ' 終了メッセージを表示
    MsgBox "データの取得が完了しました。"
    
    Exit Sub
    
ErrorHandler:
    ' エラーメッセージを表示
    MsgBox "エラーが発生しました: " & Err.Description
    
    ' エラーハンドリングのクリーンアップ
    On Error Resume Next
    If Not rs Is Nothing Then If rs.State = 1 Then rs.Close
    If Not conn Is Nothing Then If conn.State = 1 Then conn.Close
    If Not accessApp Is Nothing Then
        accessApp.CloseCurrentDatabase
        accessApp.Quit
        Set accessApp = Nothing
    End If
End Sub

'//Excel VBAコード（配列使用版）

Sub FetchDataUsingAccessVBA()
    Dim accessApp As Object
    Dim dbPath As String
    Dim connStr As String
    Dim conn As Object
    Dim rs As Object
    Dim sqlStr As String
    Dim ws As Worksheet
    Dim dataArray() As Variant
    Dim rowIndex As Long
    Dim colIndex As Long
    Dim dsn As String
    Dim uid As String
    Dim pwd As String
    Dim fieldCount As Long
    Dim recordCount As Long
    
    On Error GoTo ErrorHandler
    
    ' Accessデータベースのパスを指定
    dbPath = "D:\サンプルData.accdb"
    
    ' データを出力するExcelのシートを指定
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    ' ODBC接続情報をExcelのSheet2から取得
    With ThisWorkbook.Sheets("Sheet2")
        dsn = .Range("A1").Value
        uid = .Range("A2").Value
        pwd = .Range("A3").Value
    End With
    
    ' Accessアプリケーションを起動
    Set accessApp = CreateObject("Access.Application")
    
    ' Accessデータベースを開く
    accessApp.OpenCurrentDatabase(dbPath)
    
    ' AccessからOracleの接続文字列を取得
    connStr = accessApp.Run("GetOracleConnectionString", dsn, uid, pwd)
    
    ' ADODB.Connectionオブジェクトを作成し、Oracleに接続
    Set conn = CreateObject("ADODB.Connection")
    conn.Open connStr
    
    ' 実行するSQLクエリを設定（実際のクエリに変更）
    sqlStr = "SELECT * FROM YourTable"
    
    ' ADODB.Recordsetオブジェクトを作成し、SQLクエリを実行
    Set rs = CreateObject("ADODB.Recordset")
    rs.Open sqlStr, conn
    
    ' フィールド数を取得
    fieldCount = rs.Fields.Count
    
    ' レコード数を取得
    rs.MoveLast
    recordCount = rs.RecordCount
    rs.MoveFirst
    
    ' データを格納する配列を作成（ヘッダー行を含めるため、1行多く確保）
    ReDim dataArray(0 To recordCount, 0 To fieldCount - 1)
    
    ' フィールド名を配列の最初の行に格納
    For colIndex = 0 To fieldCount - 1
        dataArray(0, colIndex) = rs.Fields(colIndex).Name
    Next colIndex
    
    ' データを配列に格納
    rowIndex = 1
    Do While Not rs.EOF
        For colIndex = 0 To fieldCount - 1
            dataArray(rowIndex, colIndex) = rs.Fields(colIndex).Value
        Next colIndex
        rs.MoveNext
        rowIndex = rowIndex + 1
    Loop
    
    ' 配列の内容を一括でExcelに書き込み
    ws.Range(ws.Cells(1, 1), ws.Cells(recordCount + 1, fieldCount)).Value = dataArray
    
    ' クリーンアップ
    rs.Close
    conn.Close
    Set rs = Nothing
    Set conn = Nothing
    
    ' Accessアプリケーションを閉じる
    accessApp.CloseCurrentDatabase
    accessApp.Quit
    Set accessApp = Nothing
    
    ' 終了メッセージを表示
    MsgBox "データの取得が完了しました。"
    
    Exit Sub
    
ErrorHandler:
    ' エラーメッセージを表示
    MsgBox "エラーが発生しました: " & Err.Description
    
    ' エラーハンドリングのクリーンアップ
    On Error Resume Next
    If Not rs Is Nothing Then If rs.State = 1 Then rs.Close
    If Not conn Is Nothing Then If conn.State = 1 Then conn.Close
    If Not accessApp Is Nothing Then
        accessApp.CloseCurrentDatabase
        accessApp.Quit
        Set accessApp = Nothing
    End If
End Sub