Option Explicit
Sub CompareAndSaveData()
Dim accessApp As Object
Dim excelApp As Object
Dim excelWorkbook As Object
Dim accessTable As Object
Dim excelWorksheet As Object
Dim currentDate As String
Dim newWorkbookPath As String
' Access データベースのパスを設定
Dim accessDBPath As String
accessDBPath = "Z:\Work\Database12.accdb" ' ここに実際のファイル名を入力
' Excel ファイルのパスを設定
Dim excelFilePath As String
excelFilePath = "Z:\Work\ExcelFile.xlsx" ' ここに実際のファイル名を入力
' Access アプリケーションを起動
Set accessApp = CreateObject("Access.Application")
accessApp.OpenCurrentDatabase accessDBPath
' Excel アプリケーションを起動
Set excelApp = CreateObject("Excel.Application")
Set excelWorkbook = excelApp.Workbooks.Open(excelFilePath)
Set excelWorksheet = excelWorkbook.Worksheets(1) ' 1はシートのインデックスです。必要に応じて変更してください。
' 新しいブックの保存先パスを設定
currentDate = Format(Date, "YYYYMMDD")
newWorkbookPath = "Z:\Work\NewWorkbook_" & currentDate & ".xlsx" ' ここに実際のファイル名を入力
' データの比較処理
Dim accessRecordset As Object
Dim excelRow As Integer
Dim accessPrice As Double
Dim excelPrice As Double
' 項目1と項目2の列のインデックスを設定
Dim keyColumn As Integer
Dim dimensionColumn As Integer
keyColumn = 1 ' 項目1の列（1列目）を指定
dimensionColumn = 2 ' 項目2の列（2列目）を指定
' エクセルのデータを最終行まで取得
Dim lastRow As Integer
lastRow = excelWorksheet.Cells(excelWorksheet.Rows.Count, keyColumn).End(-4162).Row ' -4162 は xlUp の定数です
' データの比較処理
For excelRow = 2 To lastRow ' ヘッダーがある場合は2から始めます
' エクセルからデータを取得
Dim excelKey As String
Dim excelDimension As String
excelKey = excelWorksheet.Cells(excelRow, keyColumn).Value
excelDimension = excelWorksheet.Cells(excelRow, dimensionColumn).Value
excelPrice = excelWorksheet.Cells(excelRow, 4).Value ' エクセルの単価（4列目）を取得
' アクセスからデータを取得
Set accessRecordset = accessApp.CurrentDb.OpenRecordset("SELECT * FROM [項目1項目2調査] WHERE 項目1='" & excelKey & "' AND 項目2='" & excelDimension & "'")
If Not accessRecordset.EOF Then
accessPrice = accessRecordset.Fields("単価").Value ' アクセスの単価を取得
' エクセルにアクセスの単価を記載
excelWorksheet.Cells(excelRow, 5).Value = accessPrice
' 単価の差異をチェック
If excelPrice <> accessPrice Then
' 単価に差異がある場合、差異結果を隣の列に記載
excelWorksheet.Cells(excelRow, 6).Value = "差異あり"
' 差額を計算してセルに記載
excelWorksheet.Cells(excelRow, 7).Value = Format(excelPrice - accessPrice, "0.00") ' 差額を小数点第二位に表示
Else
' 差額なしの項目には「差異チェック」を表示
excelWorksheet.Cells(excelRow, 6).Value = "差異なし"
excelWorksheet.Cells(excelRow, 7).Value = Format(excelPrice - accessPrice, "0.00") ' 差額を小数点第二位に表示
End If
Else
' アクセスに対応するデータが存在しない場合の処理を追加するか
' アクセスに対応するデータが存在しない場合の処理を追加するかメッセージを表示するなど
' ここではメッセージボックスを表示しています
MsgBox "項目1: " & excelKey & "、項目2: " & excelDimension & "がアクセスに存在しません。"
' アクセスに対応するデータがない場合でも、差異結果を隣の列に記載
excelWorksheet.Cells(excelRow, 6).Value = "差異あり"
' 差額なしの項目には「差異チェック」を表示
excelWorksheet.Cells(excelRow, 7).Value = "0.00"
End If
excelWorksheet.Cells(1, 5).Value = "テーブル＠"
excelWorksheet.Cells(1, 6).Value = "差異チェック"
excelWorksheet.Cells(1, 7).Value = "差異＠"
accessRecordset.Close
Next excelRow
' 新しいExcelファイルにデータを保存
excelWorkbook.SaveAs newWorkbookPath
MsgBox "データが比較され、新しいブックが保存されました。"
' 終了処理
excelApp.Quit
accessApp.Quit
Set excelWorkbook = Nothing
Set accessApp = Nothing
End Sub
