こんにちは！ 健史です。
Excelシートで、
「レイアウトも格納されているデータの順番も同じ２つのシートから、内容の違っているセルを探したい！」
ってことありませんか。
「説明は要(い)らないから、すぐに実行したい！」方は、3.すぐに実行したいにスキップ下さい。
行数が1万行とか、あまりにも多い場合に人間の目で比較して探すのは、時間が掛かり見落としもあったりとたいへんな作業です。
２つのシートから３つ目のシートに異なるセルをピックアップするプログラムを作成しました。
プログラムであれば、早くて正確にピックアップできます。
尚この記事は、Excel-VBAを起動して貼り付ければ動作することを目指しています。
Excel-VBAの構造、起動方法、実行方法などを理解されていない方は、以下の記事を参照しながら一度やってみてから対応されることをお勧めします。
実行中に発生したエラーの対処法は、上記記事の2.エラーが発生したときの対処法に記載しています。(この段落のリンクから直接遷移します)
プログラムの作成と実行
今回のサンプルプログラムは
です。
プログラムの概要は以下の通りです。
・同じフォーマットで一部の値が異なる２つのシートがあり、シート３に「値が異なるセルの内容」を出力する
・基のシートの異なる部分には、マーキングする
データ量が多い場合、目視で探すのは不可能に近く、見間違えもあり非効率です。
そんな時に対応するプログラムです。
ファイルの更新系プログラム(追加・削除を伴わない)のテスト確認で、更新前後のファイルを比較するときなどにも使えます。
実行までの手順
1.Excelを起動
2.データ入力
Excel2007以降は、Sheet1のみであるためシートを２つ追加し、全部で３つ作成しておきます。
Book1のSheet1とSheet2のセル[A1]～[E5]に、分かりやすいようにセルの番号を入力します。
そして、Sheet1とSheet2の何ヵ所かの値を変えます。
3.Excel-VBAを起動
Altを押した状態でF8キーを押します。
4.[マクロ名(M):]に'test'と入力(''は不要、''内のtestを入力)
5.[作成(C)]をクリック
私はマクロ名を入力したら、そのままEnterを押します。
6.以下のプログラムをドラッグ＆コピー
'変数定義
Dim ix1, iy1, ix3 As Long
'初期クリア
Sheets(1).Cells.ClearFormats
Sheets(2).Cells.ClearFormats
Sheets(3).Cells.Clear
'シートの見出し設定
Sheets(3).Cells(1, 1) = "セル"
Sheets(3).Cells(1, 2) = "シート１"
Sheets(3).Cells(1, 3) = "シート２"
'
ix3 = 1
For ix1 = 1 To 5
For iy1 = 1 To 5
If Sheets(1).Cells(ix1, iy1) <> Sheets(2).Cells(ix1, iy1) Then
ix3 = ix3 + 1
Sheets(3).Cells(ix3, 1) = Sheets(1).Cells(ix1, iy1).Address
Sheets(3).Cells(ix3, 1) = Replace(Sheets(3).Cells(ix3, 1), "$", "")
Sheets(3).Cells(ix3, 2) = Sheets(1).Cells(ix1, iy1)
Sheets(3).Cells(ix3, 3) = Sheets(2).Cells(ix1, iy1)
Sheets(1).Cells(ix1, iy1).Interior.Color = vbRed
Sheets(2).Cells(ix1, iy1).Interior.Color = vbYellow
End If
Next
Next
'
If ix3 = 1 Then
MsgBox "OK 異なるデータはありません！"
Else
MsgBox "NG 異なるデータがあります！"
End If
6.以下に貼り付け(ペースト)
Sub test()
ここに貼り付ける
End Sub
7.F5キーで実行
8.実行結果の確認
Book1に切り替えて下さい。
Altを押した状態でTabキーを押して、Book1に位置づいたらTabキーを離すことで切り替わります。
シート１、シート２でマーキングされているセルが異なる部分です。
シート３には、異なる内容が出力されています。
プログラムの補足説明
・Cells.ClearFormats、Cells.Clear について
都度、シートを別ファイルから持ってきたり、sheet3は手でクリアしたり、削除して再度作成するなどの対応であれば不要です。
・.Address について
セル番号を出力する方法は他にもありまが、[.Address]がスッキリしているので採用しました。
ですが、[$A$1]のように'$'が付いてきます。そのため次の命令[Replace]で、'$'を無くす処理を入れました。
・Interior.Color について
ネットにて'vbcolor'で検索できます。
・比較する範囲を自動で設定する
上記プログラムでは、行と列の数を「5」と固定した値で作成しました。
Sheet1のセル[A1]にカーソルがある状態で[Crtl]&[End]キー押して、データが格納されている最後の行列を取得し使用する場合には以下のようにします。
'追加
Dim ix1_max ,jy1_max As Long
'追加
ix1_max = Sheets(1).Range("A1").SpecialCells(xlLastCell).Row
iy1_max = Sheets(1).Range("A1").SpecialCells(xlLastCell).Column
'修正
For ix1 = 1 To ix1_max
For iy1 = 1 To iy1_max
最後に
このプログラムは、シート１とシート２について、セル[A1][A2][A3][A4][A5][B1][B2]・・・[C3][C4][C5]と一つひとつ比較し、異なる部分をシート３に出力するプログラムでした。
最初のシートフォーマットやシートをクリアする処理、セルにマーキングする処理が不要だったり、逆にシート３に出力する処理が不要だったり、ケースは多々あると思います。
使うシーンに応じて対応して頂ければと思います。
すぐに実行したい
２つのファイルを手動で１つのファイルに集約して準備
以下の条件でデータが揃っていれば、VBAを起動し貼り付け実行できます。
・Sheet1とSheet2に行列数とも同じ比較対象データを格納しておく
・Sheet3を空白で作成しておく
処理の最初に確認のため、比較対象の行数と列数をメッセージ表示していますが、[OK]ボタンをクリックします。
'変数定義
Dim ix1, iy1, ix3 As Long
Dim ix1_max, iy1_max As Long
'初期クリア
Sheets(1).Cells.ClearFormats
Sheets(2).Cells.ClearFormats
Sheets(3).Cells.Clear
'シート3の見出し設定
Sheets(3).Cells(1, 1) = "セル"
Sheets(3).Cells(1, 2) = "シート１"
Sheets(3).Cells(1, 3) = "シート２"
'セル[A1]で Ctrl+Endを押したときの最終行と最終列を取得
ix1_max = Sheets(1).Range("A1").SpecialCells(xlLastCell).Row
iy1_max = Sheets(1).Range("A1").SpecialCells(xlLastCell).Column
'確認のため比較対象の行数と列数をメッセージ表示
MsgBox "最終行は " & ix1_max & "、最終列は " & iy1_max
'Sheet3の添え字初期値設定
ix3 = 1
'比較処理
For ix1 = 1 To ix1_max
For iy1 = 1 To iy1_max
If Sheets(1).Cells(ix1, iy1) <> Sheets(2).Cells(ix1, iy1) Then
ix3 = ix3 + 1
Sheets(3).Cells(ix3, 1) = Sheets(1).Cells(ix1, iy1).Address
Sheets(3).Cells(ix3, 1) = Replace(Sheets(3).Cells(ix3, 1), "$", "")
Sheets(3).Cells(ix3, 2) = Sheets(1).Cells(ix1, iy1)
Sheets(3).Cells(ix3, 3) = Sheets(2).Cells(ix1, iy1)
Sheets(1).Cells(ix1, iy1).Interior.Color = vbRed
Sheets(2).Cells(ix1, iy1).Interior.Color = vbYellow
End If
Next
Next
'
If ix3 = 1 Then
MsgBox "OK 異なるデータはありません！"
Else
MsgBox "NG 異なるデータがあります！"
End If
２つのファイルを自動で読み込み比較表を作成
比較するファイルを手動で開いて別のExcelにコピーしたり貼り付けるのではなく、自動で読み込んでコピーしてファイルを作成するプログラムです。
このプログラムも比較するファイルの行列数とも同じであることが条件です。
所定のフォルダに比較対象のファイルを２つ格納してプログラムを実行すると、２つのファイルを新たオープンしたファイルのシート１、シート２にコピーして、かつ、異なるセル情報をシート３に出力してファイルを作成します。
＜実行前＞
＜実行後＞
手順は以下です。
1.比較対象のファイルを格納
この説明では１つのフォルダ内に格納していますが、アクセスできるフォルダであればどこでも構いません。
上記イメージの「データファイル1.xlsx」、「データファイル2.xlsx」です。
2.Excelを起動し、格納した比較するファイルの所在を２つ、比較した結果のファイルを指定
上記イメージの「比較表作成.xlsm」は、当設定シートと[3.]のプログラムが一体となったマクロファイルです。
１度だけの実行であればマクロファイルとして保存しておく必要はありません。
プログラム実行の最後に保存する・しないの確認があり、Excel2007以降であればマクロを選択して保存します。
3.以下のプログラムをコピー、ExcelVBAを起動し、マクロの作成で貼り付けて実行
ExcelVBAの起動は、Altを押した状態でF8キーを押します。
貼り付けでは、'Sub マクロ名()～End Sub'の全てを消してから貼り付けます。
このとき作成で指定したマクロ名が[compare]に置き換わりますので、指定したマクロ名にしたい場合は貼り付けたあとに[compare]を修正します。
Sub compare()
'変数定義
Dim ix1, iy1, ix3, cntSht As Long
Dim ix1_max, iy1_max As Long
Dim excel0, excel1, excel2 As Workbook
'ファイルパス名
Dim strPath1, strPath2, strPath3 As String
'をexcel0にセット
Set excel0 = ActiveWorkbook
'起動用WBから処理するパスをワークへセット
strPath1 = Sheets(1).Cells(1, 2)
strPath2 = Sheets(1).Cells(2, 2)
strPath3 = Sheets(1).Cells(3, 2)
'パスの存在チェック
If Dir(strPath1, vbDirectory) = "" Then
MsgBox "比較対象１がない", vbExclamation
Exit Sub
End If
If Dir(strPath1, vbDirectory) = "" Then
MsgBox "比較対象２がない", vbExclamation
Exit Sub
End If
'比較表WBを新規にオープン
Set excel2 = Workbooks.Add
'比較対象１をオープン、比較表WBへコピー、シート名を変更
Workbooks.Open strPath1
Set excel1 = ActiveWorkbook
excel1.Sheets(1).Copy before:=excel2.Sheets(excel2.Sheets.Count)
excel1.Close
excel2.Sheets(1).Name = Filename(strPath1)
'比較対象２をオープン、比較表WBへコピー、シート名を変更
Workbooks.Open strPath2
Set excel1 = ActiveWorkbook
excel1.Sheets(1).Copy before:=excel2.Sheets(excel2.Sheets.Count)
excel1.Close
excel2.Sheets(2).Name = Filename(strPath2)
excel2.Sheets(3).Name = "差"
'比較表WBのシート3の見出し設定
excel2.Sheets(3).Cells(1, 1) = "セル"
excel2.Sheets(3).Cells(1, 2) = "シート１"
excel2.Sheets(3).Cells(1, 3) = "シート２"
'セル[A1]で Ctrl+Endを押したときの最終行と最終列を取得
ix1_max = excel2.Sheets(1).Range("A1").SpecialCells(xlLastCell).Row
iy1_max = excel2.Sheets(1).Range("A1").SpecialCells(xlLastCell).Column
'Sheet3の添え字初期値設定
ix3 = 1
'比較処理
For ix1 = 1 To ix1_max
For iy1 = 1 To iy1_max
If excel2.Sheets(1).Cells(ix1, iy1) <> excel2.Sheets(2).Cells(ix1, iy1) Then
ix3 = ix3 + 1
excel2.Sheets(3).Cells(ix3, 1) = excel2.Sheets(1).Cells(ix1, iy1).Address
excel2.Sheets(3).Cells(ix3, 1) = Replace(excel2.Sheets(3).Cells(ix3, 1), "$", "")
excel2.Sheets(3).Cells(ix3, 2) = excel2.Sheets(1).Cells(ix1, iy1)
excel2.Sheets(3).Cells(ix3, 3) = excel2.Sheets(2).Cells(ix1, iy1)
excel2.Sheets(1).Cells(ix1, iy1).Interior.Color = vbRed
excel2.Sheets(2).Cells(ix1, iy1).Interior.Color = vbYellow
End If
Next
Next
'各シートのカーソルをA1へ移動しておく。ファイルを開いたときに１番目のシートでカーソルがA1にあるように
'最後尾のシートから前のシートへとA1に位置付ける
For cntSht = excel2.Sheets.Count To 1 Step by - 1
Application.Goto Reference:=excel2.Sheets(cntSht).Cells(1, 1), Scroll:=True
Next
If Dir(strPath3, vbDirectory) = "" Then
excel2.SaveAs strPath3
Else
MsgBox "出力ファイルがあります。上書保存しません。" & vbCrLf & vbCrLf & _
"ファイル名を変更するか削除してからもう一度実行して下さい！", vbExclamation
End If
excel2.Close (False)
Application.Quit
End Sub
’ファイル名取得
Function Filename(ByVal Path As String) As String
Dim strRev As String
Dim pos_st, pos_end, pos_len As Long
strRev = StrReverse(Path)
pos_st = InStr(1, strRev, ".")
pos_st = pos_st + 1
pos_end = InStr(1, strRev, "\")
pos_len = pos_end - pos_st
Filename = StrReverse(Mid(strRev, pos_st, pos_len))
End Function
コメント