Access＆Excelサンプル

◆◆◆Access◆◆◆

'----------------------

'標準モジュール＞インポート

'----------------------

Option Compare Database
Option Explicit

Public Sub ImportMain()
    Debug.Print "//--- ImportMain start ---"
   
    '削除クエリ実行
    Debug.Print "//--- ImportMain 削除クエリ実行"

    DoCmd.SetWarnings False
    DoCmd.OpenQuery "削除Q機器"
    DoCmd.OpenQuery "削除Q設置場所"
    DoCmd.SetWarnings True
   
    'インポート実行
    Debug.Print "//--- ImportMain インポート実行"
    Dim vPath As String
    Dim root As String
    root = Left(CurrentProject.Path, InStrRev(CurrentProject.Path, "\"))
    vPath = root & "インポート\"
    DoCmd.TransferSpreadsheet acImport, , "T機器", vPath & "機器データ.xlsx", True
    DoCmd.TransferSpreadsheet acImport, , "T設置場所", vPath & "設置場所データ.xlsx", True

    'MsgBox "インポート完了", vbInformation
    Debug.Print "//--- ImportMain end ---"

End Sub

'----------------------

'標準モジュール＞インポート

'----------------------

Option Compare Database
Option Explicit

Public Sub ExportMain()
    Debug.Print "//--- ExportMain start ---"
   
    Dim root As String
    root = Left(CurrentProject.Path, InStrRev(CurrentProject.Path, "\"))
   
    'ファイルをコピーする
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
    fso.CopyFile CurrentProject.Path & "\抽出結果_雛形.xlsx", root & "エクスポート\抽出結果.xlsx"
    If Err.Number <> 0 Then 'エラー発生時は終了
        MsgBox "エクスポートファイル作成中にエラーが発生しました。" & vbCrLf _
            & "[エラー番号]" & Err.Number & vbCrLf & "[内容]" & Err.Description
        Exit Sub
    End If
    On Error GoTo 0
    Set fso = Nothing
    Debug.Print "//--- ExportMain ファイルをコピー終了"
 
    'エクスポート実行
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim xlApp As Object
    Dim wb As Object
    Dim sh As Object
    Dim vPath As String
    vPath = root & "エクスポート\"
   
    'ブックを開く
    Set xlApp = CreateObject("Excel.Application")
    Set wb = xlApp.Workbooks.Open(vPath & "抽出結果.xlsx")
   
    'カレントDBへ接続
    Set db = CurrentDb
   
    'クエリをシートへ出力
    Set sh = wb.Worksheets("機器")
    Set rs = db.OpenRecordset("Q機器", dbOpenDynaset)   'レコードセット取得
    sh.Range("A2").CopyFromRecordset rs
   
    Set sh = wb.Worksheets("設置場所")
    Set rs = db.OpenRecordset("Q設置場所", dbOpenDynaset)
    sh.Range("A2").CopyFromRecordset rs
   
    Set sh = wb.Worksheets("結合")
    Set rs = db.OpenRecordset("Q結合", dbOpenDynaset)
    sh.Range("A2").CopyFromRecordset rs

    Set sh = wb.Worksheets("機器_一意でないKey")
    Set rs = db.OpenRecordset("Q機器_一意でないKeyのレコード", dbOpenDynaset)
    sh.Range("A2").CopyFromRecordset rs
   
    Set sh = wb.Worksheets("設置場所_一意でないKey")
    Set rs = db.OpenRecordset("Q設置場所_一意でないKeyのレコード", dbOpenDynaset)
    sh.Range("A2").CopyFromRecordset rs
 
    'レコードセットを閉じる
    rs.Close
    'DBへの接続を閉じる
    db.Close
 
    'ブックを閉じる
    wb.Close SaveChanges:=True
    Set sh = Nothing
    Set wb = Nothing
    xlApp.Quit: Set xlApp = Nothing
   
   
    'MsgBox "エクスポート完了", vbInformation
    Debug.Print "//--- ExportMain end ---"

End Sub

◆◆◆Excel◆◆◆

'----------------------

'標準モジュール

'----------------------

Sub データ抽出()

    'Dim root As String
    'root = Left(ActiveWorkbook.path, InStrRev(ActiveWorkbook.path, "\"))

    Dim objAccess As Object

    'ACCESSオープンImportMain
    Set objAccess = CreateObject("Access.Application")
    Call objAccess.OpenCurrentDatabase(ActiveWorkbook.path & "\部品\DB.accdb")

    'Publicプロシージャ実行
    objAccess.Run "ImportMain"
    objAccess.Run "ExportMain"

    'ACCESSクローズ
    objAccess.CloseCurrentDatabase
    Set objAccess = Nothing
   
    MsgBox "完了"
   
End Sub