Sub TransferDataToOracleAndExportToExcel()
Dim conn As Object
Dim accessDb As DAO.Database
Dim accessRs As DAO.Recordset
Dim excelApp As Object
Dim excelWorkbook As Object
Dim excelWorksheet As Object
Dim savePath As String
Dim fileName As String
Dim currentDate As String
Dim accessDbPath As String
Dim accessTableName As String
Dim connectionString As String
Dim sqlInsert As String
' Accessデータベースのパス
accessDbPath = "C:\path\to\your\database.accdb" ' 実際のパスに置き換えてください
accessTableName = "YourAccessTable" ' 実行したいテーブル名を指定
' Oracle ODBC接続文字列を設定
connectionString = "ODBC;DSN=YourDSN;UID=YourUserID;PWD=YourPassword;" ' 実際の情報に置き換え
' 保存先のパスを指定（デスクトップ）
savePath = Environ("USERPROFILE") & "\Desktop\"
' 現在の日付と時刻をフォーマットして取得
currentDate = Format(Now, "yyyymmddhhmmss")
' ファイル名を指定
fileName = "SearchResult_" & currentDate & ".xlsx"
' Accessデータベースをオープン
Set accessDb = DBEngine.OpenDatabase(accessDbPath)
Set accessRs = accessDb.OpenRecordset("SELECT * FROM " & accessTableName)
' Excelアプリケーションを起動
Set excelApp = CreateObject("Excel.Application")
Set excelWorkbook = excelApp.Workbooks.Add
Set excelWorksheet = excelWorkbook.Sheets(1)
' ヘッダーを追加
For i = 0 To accessRs.Fields.Count - 1
excelWorksheet.Cells(1, i + 1).Value = accessRs.Fields(i).Name
Next i
' データを転記
Dim row As Long
row = 2 ' データは2行目から始まる
Do While Not accessRs.EOF
For i = 0 To accessRs.Fields.Count - 1
excelWorksheet.Cells(row, i + 1).Value = accessRs.Fields(i).Value
Next i
' Oracleにデータを転記
sqlInsert = "INSERT INTO YourOracleTable (Column1, Column2) VALUES ('" & _
accessRs!Column1 & "', '" & accessRs!Column2 & "')" ' 実際の列名に変更
Set conn = CreateObject("ADODB.Connection")
conn.Open connectionString
conn.Execute sqlInsert
conn.Close
row = row + 1
accessRs.MoveNext
Loop
' Excelファイルを保存
excelWorkbook.SaveAs savePath & fileName
excelWorkbook.Close
excelApp.Quit
' クローズ処理
accessRs.Close
accessDb.Close
Set accessRs = Nothing
Set accessDb = Nothing
Set excelWorksheet = Nothing
Set excelWorkbook = Nothing
Set excelApp = Nothing
Set conn = Nothing
MsgBox "検索結果がデスクトップに保存されました: " & fileName
End Sub
