Excel→Accessデータ抽出(DAOパラメータ条件ある場合)

Sub Excel→Accessデータ抽出2()
    Dim AccessApp As Object
    Dim AccessDb As Object
    Dim AccessQuery As Object
    Dim AccessRecordset As Object
    Dim ExcelApp As Object
    Dim ExcelSheet As Object
    Dim AccessPath As String
    Dim i As Long
    
    ' Accessデータベースのパスを取得
    AccessPath = Sheets("Sheet1").Range("B2").Value
    
    ' Accessアプリケーションの起動
    Set AccessApp = CreateObject("Access.Application")
    
    ' Accessデータベースのオープン
    Set AccessDb = AccessApp.Application.DBEngine.OpenDatabase(AccessPath)
    
    ' パラメータの入力
    ' 例: AccessDb.QueryDefs("YourParameterQuery").Parameters("Parameter1") = Value1
    AccessDb.QueryDefs("YourParameterQuery").Parameters("Parameter1") = Value1
    AccessDb.QueryDefs("YourParameterQuery").Parameters("Parameter2") = Value2
    AccessDb.QueryDefs("YourParameterQuery").Parameters("Parameter3") = Value3
    AccessDb.QueryDefs("YourParameterQuery").Parameters("Parameter4") = Value4
    AccessDb.QueryDefs("YourParameterQuery").Parameters("Parameter5") = Value5
    
    ' クエリの実行
    Set AccessQuery = AccessDb.QueryDefs("YourQueryName")
    Set AccessRecordset = AccessQuery.OpenRecordset
    
    ' Excelアプリケーションの起動
    Set ExcelApp = CreateObject("Excel.Application")
    
    ' 新しいワークブックの作成
    ExcelApp.Workbooks.Add
    
    ' ワークシートの取得
    Set ExcelSheet = ExcelApp.Workbooks(1).Sheets(2) ' Sheet2に変更
    
    ' ヘッダ行の作成
    For i = 0 To AccessRecordset.Fields.Count - 1
        ExcelSheet.Cells(1, i + 1).Value = AccessRecordset.Fields(i).Name
    Next i
    
    ' データの転記
    ExcelSheet.Range("A2").CopyFromRecordset AccessRecordset
    
    ' クエリ実行結果の表示
    AccessRecordset.Close
    
    ' Excelの表示
    ExcelApp.Visible = True
    
    ' クリーンアップ
    Set AccessRecordset = Nothing
    Set AccessQuery = Nothing
    Set AccessDb = Nothing
    Set AccessApp = Nothing
    Set ExcelSheet = Nothing
    Set ExcelApp = Nothing
End Sub