エクセルVBAからアクセスVBAを呼び出し

◆◆◆アクセス◆◆◆

◆インポート

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
Sub test()
DeleteFromTable "機器"
End Sub

'削除クエリを実行し、テーブルからレコード削除
Sub DeleteFromTable(argTableName As String)
Debug.Print "--- DeleteFromTable start ---"
Debug.Print "[argTableName]" & argTableName
DoCmd.SetWarnings False
DoCmd.OpenQuery "削除Q" & argTableName
DoCmd.SetWarnings True
Debug.Print "--- DeleteFromTable 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



◆◆◆エクセル◆◆◆

◆標準

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


◆カスタム

Option Explicit
Dim objAccess As Object
Dim strImportTable As String
Dim arrImportTable() As String
Public Sub カスタム実行()
Debug.Print "----- カスタム実行 start -----"

'On Error GoTo ERR_HANDLER

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


ログ出力 "実行開始"
指定インポート箇所の取得
アクセスへインポートする
ログ出力 "実行終了"

ERR_HANDLER:
'ACCESSクローズ
objAccess.CloseCurrentDatabase
Set objAccess = Nothing

If Err.Number <> 0 Then
Debug.Print "エラーが発生した為中断・・・"
ログ出力 "エラーが発生した為中断"
Debug.Print "[Err.Number]" & Err.Number
Debug.Print "[Err.Description]" & Err.Description
Else
Debug.Print "正常に完了"
ログ出力 "正常に完了"
End If
Debug.Print "----- カスタム実行 end -----"
End Sub
Sub 指定インポート箇所の取得()
Debug.Print "--- 指定インポート箇所の取得 start ---"

'カンマ区切りの文字列を作成
Debug.Print "[機器データ]" & Worksheets("カスタム").Range("機器データ").Value
Debug.Print "[設置場所]" & Worksheets("カスタム").Range("設置場所").Value
Debug.Print "[サポート履歴]" & Worksheets("カスタム").Range("サポート履歴").Value

strImportTable = ""
If (Worksheets("カスタム").Range("機器データ").Value) Then
strImportTable = 文字列の区切りにカンマを付加する(strImportTable) & "機器"
End If
If (Worksheets("カスタム").Range("設置場所").Value) Then
strImportTable = 文字列の区切りにカンマを付加する(strImportTable) & "設置場所"
End If
If (Worksheets("カスタム").Range("サポート履歴").Value) Then
strImportTable = 文字列の区切りにカンマを付加する(strImportTable) & "サポート履歴"
End If

Debug.Print "[strImportTable]" & strImportTable

'配列に格納
Dim i As Long
arrImportTable = Split(strImportTable, ",")
For i = LBound(arrImportTable) To UBound(arrImportTable)
Debug.Print "[arrImportTable(" & i & ")]" & arrImportTable(i)
Next i

Debug.Print "--- 指定インポート箇所の取得 end ---"
End Sub

Sub 指定エクスポート箇所の取得()

End Sub
'Sub アクセスのデータを削除する()
' Debug.Print "--- アクセスのデータを削除するstart ---"

' Dim i As Long
' For i = LBound(arrImportTable) To UBound(arrImportTable)
' Debug.Print arrImportTable(i) & "を削除中・・・"
' ログ出力 arrImportTable(i) & "を削除中・・・"

' objAccess.Run "DeleteFromTable", "arrImportTable(i)"

' Debug.Print arrImportTable(i) & "へ削除完了"
' ログ出力 arrImportTable(i) & "を削除完了"
' Next i

' Debug.Print "--- アクセスのデータを削除する end ---"
'End Sub

Sub アクセスへインポートする()
Debug.Print "--- アクセスへインポートする start ---"

Dim i As Long
For i = LBound(arrImportTable) To UBound(arrImportTable)

Debug.Print arrImportTable(i) & "を削除中・・・"
ログ出力 arrImportTable(i) & "を削除中・・・"
objAccess.Run "DeleteFromTable", arrImportTable(i)
Debug.Print arrImportTable(i) & "へ削除完了"
ログ出力 arrImportTable(i) & "を削除完了"

Debug.Print arrImportTable(i) & "をインポート中・・・"
ログ出力 arrImportTable(i) & "をインポート中・・・"
'objAccess.Run "DeleteFromTable", "arrImportTable(i)"
Debug.Print arrImportTable(i) & "へインポート完了"
ログ出力 arrImportTable(i) & "をインポート完了"

Next i

Debug.Print "--- アクセスへインポートする end ---"
End Sub

Function 文字列の区切りにカンマを付加する(argString As String)
Dim str As String
str = argString
If str <> "" Then
str = str & ","
End If
文字列の区切りにカンマを付加する = str
End Function

Sub ログ出力(argMessage As String)
Dim n As Date
n = Now()
Worksheets("カスタム").Range("実行時間").Value = Hour(n) & ":" & Minute(n) & ":" & Second(n) & " "
Worksheets("カスタム").Range("実行結果").Value = argMessage
End Sub