Sub 比較処理マクロ()
Dim ws1 As Worksheet, ws2 As Worksheet, diffWs As Worksheet, addWs As Worksheet, delWs As Worksheet
Dim lastRow1 As Long, lastRow2 As Long, i As Long, j As Long, k As Long
Dim foundMatch As Boolean
Dim currentTime As Double
Dim deleteSheetCreated As Boolean, addSheetCreated As Boolean, diffSheetCreated As Boolean
' 現在の時間を取得
currentTime = Time
' シート1、シート2の設定
Set ws1 = ThisWorkbook.Sheets("シート1")
Set ws2 = ThisWorkbook.Sheets("シート2")
' シートの最終行を取得
lastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
lastRow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
' 差分シート、追加シート、削除シートが作成されたかどうかのフラグ
deleteSheetCreated = False
addSheetCreated = False
diffSheetCreated = False
' a列とb列の項目を比較
For i = 2 To lastRow1
foundMatch = False
' シート1のデータがシート2に存在するかチェック
For j = 2 To lastRow2
If ws1.Cells(i, 1).Value = ws2.Cells(j, 1).Value And ws1.Cells(i, 2).Value = ws2.Cells(j, 2).Value Then
' 条件③: 合致する場合は差分を計算して差分シートに転記
If Not diffSheetCreated Then
Set diffWs = Sheets.Add(After:=Sheets(Sheets.Count))
diffWs.Name = "差分シート"
diffSheetCreated = True
' 項目名転記
For k = 1 To 7
diffWs.Cells(1, k).Value = ws1.Cells(1, k).Value
Next k
End If
' データ転記
diffWs.Cells(diffWs.Cells(Rows.Count, "A").End(xlUp).Row + 1, 1).Value = ws1.Cells(i, 1).Value
diffWs.Cells(diffWs.Cells(Rows.Count, "B").End(xlUp).Row + 1, 2).Value = ws1.Cells(i, 2).Value
' 残りの列の差分を計算
For k = 3 To 7
diffWs.Cells(diffWs.Cells(Rows.Count, "A").End(xlUp).Row, k).Value = ws1.Cells(i, k).Value - ws2.Cells(j, k).Value
Next k
foundMatch = True
Exit For
End If
Next j
' 条件①: シート1のデータがシート2に存在しない場合は削除シートに転記
If Not foundMatch Then
If Not deleteSheetCreated Then
Set delWs = Sheets.Add(After:=Sheets(Sheets.Count))
delWs.Name = "削除シート"
' 項目名転記
For k = 1 To 7
delWs.Cells(1, k).Value = ws1.Cells(1, k).Value
Next k
deleteSheetCreated = True
End If
' データ転記
delWs.Cells(delWs.Cells(Rows.Count, "A").End(xlUp).Row + 1, 1).Value = ws1.Cells(i, 1).Value
delWs.Cells(delWs.Cells(Rows.Count, "B").End(xlUp).Row + 1, 2).Value = ws1.Cells(i, 2).Value
' 残りの列の値を転記
For k = 3 To 7
delWs.Cells(delWs.Cells(Rows.Count, "A").End(xlUp).Row, k).Value = ws1.Cells(i, k).Value
Next k
End If
Next i
' 条件②: シート2のデータがシート1に存在しない場合は追加シートに転記
For i = 2 To lastRow2
foundMatch = False
' シート2のデータがシート1に存在するかチェック
For j = 2 To lastRow1
If ws2.Cells(i, 1).Value = ws1.Cells(j, 1).Value And ws2.Cells(i, 2).Value = ws1.Cells(j, 2).Value Then
foundMatch = True
Exit For
End If
Next j
' シート1に存在しない場合は追加シートに転記
If Not foundMatch Then
If Not addSheetCreated Then
Set addWs = Sheets.Add(After:=Sheets(Sheets.Count))
addWs.Name = "追加シート"
' 項目名転記
For k = 1 To 7
addWs.Cells(1, k).Value = ws1.Cells(1, k).Value
Next k
addSheetCreated = True
End If
' データ転記
addWs.Cells(addWs.Cells(Rows.Count, "A").End(xlUp).Row + 1, 1).Value = ws2.Cells(i, 1).Value
addWs.Cells(addWs.Cells(Rows.Count, "B").End(xlUp).Row + 1, 2).Value = ws2.Cells(i, 2).Value
' 残りの列の値を転記
For k = 3 To 7
addWs.Cells(addWs.Cells(Rows.Count, "A").End(xlUp).Row, k).Value = ws2.Cells(i, k).Value
Next k
End If
Next i
End Sub
