シートデータ比較

Sub Compare_Test()
'
'beforeのファイル/シート選択
'afterのファイル/シート選択
Dim BfFilePath As Variant: BfFilePath = "xxx"
Dim BfFileName As Variant: BfFileName = "xxx.xlsx"
Dim BfSheetName As Variant: BfSheetName = "before"
Dim AfFilePath As Variant: AfFilePath = "xxxx"
Dim AfFileName As Variant: AfFileName = "xxxx.xlsx"
Dim AfSheetName As Variant: AfSheetName = "after"
Dim ResultSheetName As Variant
Dim BfBookObj As Workbook ' 相手ブック
Dim BfSheetObj As Worksheet ' 相手シート
Dim AfBookObj As Workbook ' 相手ブック
Dim AfSheetObj As Worksheet ' 相手シート

Dim bf_S_Row As Integer: bf_S_Row = 3
Dim bf_S_Colom As Integer: bf_S_Colom = 1
Dim af_S_Row As Integer: af_S_Row = 3
Dim af_S_Colom As Integer: af_S_Colom = 1

Dim bf_Row_cnt As Integer
Dim af_Row_cnt As Integer
Dim check_Row_cnt As Integer: check_Row_cnt = 2
Dim check_flg As Boolean


If XXXXXX(BfFileName) = True Then
Set BfBookObj = Workbooks(BfFileName)
Set BfSheetObj = Workbooks(BfFileName).Worksheets(BfSheetName) ' シートのオブジェクトを取得

Else
Set BfBookObj = Workbooks.Open(BfFilePath & BfFileName)
Set BfSheetObj = BfBookObj.Worksheets(BfSheetName) ' シートのオブジェクトを取得

End If

If XXXXXX(AfFileName) = True Then
Set AfBookObj = Workbooks(AfFileName)
Set AfSheetObj = Workbooks(AfFileName).Worksheets(AfSheetName) ' シートのオブジェクトを取得

Else
Set AfBookObj = Workbooks.Open(AfFilePath & AfFileName)
Set AfSheetObj = AfBookObj.Worksheets(AfSheetName) ' シートのオブジェクトを取得

End If



'afterシートをafter_比較シートでコピー
ResultSheetName = AfSheetName & "_比較_" & Format(Now, "yymmdd_hhmmss")
AfBookObj.Worksheets(AfSheetName).Copy After:=AfBookObj.Worksheets(AfSheetName)
ActiveSheet.Name = ResultSheetName

'after_比較シートをアクティブ
AfBookObj.Worksheets(ResultSheetName).Activate

'afterデータ列がなくなるまでループ
af_Row_cnt = 0
Do While Cells(af_S_Row + af_Row_cnt, af_S_Colom).Value <> ""
'beforeのデータが一致するまでループ
bf_Row_cnt = 0
check_flg = False
Do While BfSheetObj.Cells(bf_S_Row + bf_Row_cnt, bf_S_Colom).Value <> ""
If BfSheetObj.Cells(bf_S_Row + bf_Row_cnt, bf_S_Colom).Value = _
Cells(af_S_Row + af_Row_cnt, af_S_Colom).Value Then


'チェック処理
For Cnt = 1 To check_Row_cnt
If BfSheetObj.Cells(bf_S_Row + bf_Row_cnt, bf_S_Colom + Cnt).Value <> _
Cells(af_S_Row + af_Row_cnt, af_S_Colom + Cnt).Value Then

Cells(af_S_Row + af_Row_cnt, af_S_Colom + Cnt).Interior.Color = RGB(255, 255, 0)
End If
Next

check_flg = True
Exit Do
End If

bf_Row_cnt = bf_Row_cnt + 1
Loop


If check_flg = False Then
'beforに該当なしの処理
For Cnt = 0 To check_Row_cnt
Cells(af_S_Row + af_Row_cnt, af_S_Colom + Cnt).Interior.Color = RGB(0, 255, 0)
Next
End If


af_Row_cnt = af_Row_cnt + 1
Loop


End Sub

 

Excelのファイル指定方法

■ファイル

ActiveWorkbook … 現在、アクティブなExcel
ThisWorkbook … マクロが書き込まれている自身のExcel
ActiveSheet … 現在、アクティブなシート
ThisWorkSheet … マクロが書き込まれている自身のExcel

■アクティブ化
Workbooks(sample.xlsx).Activate

■例

Dim path_n as string: string = "\sample.xlsx"
Dim WB1 As Workbook : Set WB1 = ActiveWorkbook
Dim WH1 As Worksheet: Set WH1 = ActiveWorkbook.ActiveWorkbook
Dim WB2 As Workbook : Set WB2 = Workbooks.Open(WB1.Path & "\dsmplr.xlsx")
Dim WH2 As Worksheet: Set WB2 = Workbook.Worksheets("Sheet1")

Excelの別ファイルへのセルコピー

 

=============================================================

Sub 追加機能()
'
' 追加機能 Macro
'
'ユーザ側でマージ先を指定
Dim OpenFileName As String
Dim readBook As Workbook ' 相手ブック
Dim readSheet As Worksheet ' 相手シート

' OpenFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xlsx") ' ファイルを選択
' Set readBook = Workbooks.Open(OpenFileName) ' ファイルを開く
Set readBook = Workbooks.Open(ThisWorkbook.Path & "\Base.xlsx") ' ファイルを開く
Set readSheet = readBook.Worksheets("add1") ' シートのオブジェクトを取得

Windows(ThisWorkbook.Name).Activate ' 追加ファイルをアクティブ

Dim bf_Row As Integer '追加元ファイルの行
Dim bf_Colom As Integer '追加元ファイルの列
Dim af_Row As Integer
Dim af_Colom As Integer

Dim bf_cnt As Integer
Dim af_cnt As Integer
bf_Row = 3
bf_Colom = 4
af_Row = 3
af_Colom = 4

'追加元ファイルのheadからtail end(Blank cell)までループ
bf_cnt = 0
Do While Cells(bf_Row + bf_cnt, bf_Colom).Value <> ""
af_cnt = 0

'追加先ファイルをheadからtail end(Blank cell)までチェック
Do While readSheet.Cells(af_Row + af_cnt, af_Colom).Value <> ""

If Cells(bf_Row + bf_cnt, bf_Colom - 2).Value = "Common" Then
'Commmon Patten
If readSheet.Cells(af_Row + af_cnt, af_Colom).Value = Cells(bf_Row + bf_cnt, bf_Colom).Value Then
'チェック行のright 右２行をコピー
readSheet.Cells(af_Row + af_cnt, af_Colom + 1).Value = Cells(bf_Row + bf_cnt, bf_Colom + 1).Value
readSheet.Cells(af_Row + af_cnt, af_Colom + 2).Value = Cells(bf_Row + bf_cnt, bf_Colom + 2).Value
GoTo Label1
End If
End If

af_cnt = af_cnt + 1
Loop
Label1:
If Cells(bf_Row + bf_cnt, bf_Colom - 2).Value <> "Common" Then
readSheet.Cells(af_Row + af_cnt, af_Colom - 2).Value = Cells(bf_Row + bf_cnt, bf_Colom - 2).Value
readSheet.Cells(af_Row + af_cnt, af_Colom - 1).Value = Cells(bf_Row + bf_cnt, bf_Colom - 1).Value
readSheet.Cells(af_Row + af_cnt, af_Colom).Value = Cells(bf_Row + bf_cnt, bf_Colom).Value
readSheet.Cells(af_Row + af_cnt, af_Colom + 1).Value = Cells(bf_Row + bf_cnt, bf_Colom + 1).Value
readSheet.Cells(af_Row + af_cnt, af_Colom + 2).Value = Cells(bf_Row + bf_cnt, bf_Colom + 2).Value
End If

bf_cnt = bf_cnt + 1
Loop

End Sub