エクセルのシートとシートを比較するマクロ
今や様々な仕事の現場で使われている「エクセル」
色んな人が使っている割に、エクセルのマクロを使えるという人は少ないのではないのでしょうか？
もっとこんな機能あったらいいのに！その夢。。。エクセルマクロが叶えてくれます
例えば、エクセルのシートとシートを比較してくれるという機能
あったらいいなと思ったことはありませんか？
え？ない？
ま、ままそう言わずお付き合いしてくれよ
そんなわけで、今回はシートとシートを比較するマクロのお勉強です！
※ソースコード全文は記事の最後に記載します
エクセルのシートとシートを比較する機能
言うは簡単、でも作るのも割と簡単
一番難しかったのは、比較する２つのシートをどう選択するのか？これにつきる感じでござんした
今回は一番コードとして楽な手法を取っています
①比較するシート２つを決定せよ
シート同士の比較なので、もちろん選ぶべきシートは「２つ」
シート１つじゃ比較なんてできません
３つは？４つは？と思う方もいるかもしれませんが、今回は「２つ」です！
実際に現場では比較したいシートというのは、ブックを跨いでいたりするもんですね
とは言え、ブックを跨いでるシートの比較というのは正直めんどう
ユーザーフォームを駆使すれば、何とかなるかもしれませんが、今回はブックの中に比較したいシートが２つのみある状態を前提に話を進めていきましょう
つまりは、以下の状態である前提
シート比較.xlsmというブックに、比較したいシートが２つ（この場合「比較A」、「比較B」）ある状態
初めに前提が正しいのか？確認します
現在のワークシート数を"Worksheets.Count"にて確認
シート数が２じゃない場合、処理を終了する
シート数が２の場合、シートを変数へと格納しちゃう。。。という処理
ブックに対して、シート数２というのが正しい状態
シート数が2以外の場合、マクロは終了
②比較するシートが決まったら比較せよ
比較したいシートが決まったら、後は比較すればよし
比較用に適当なシートを用意
シート「あああ」
シート「いいい」
比較処理1回目は「あああ」⇒「いいい」で比較
If Len(OldStr) > 0 Then
詳細は省きますが、空白セルは無視するという処理
これが後々、若干の不便さを生む
比較処理2回目は「いいい」⇒「あああ」で比較
差分が出た箇所はわかりやすく塗りつぶし処理を行うことで、比較終了
マクロの実行結果は以下の通り
２つのシートを比較して、差分のみを抜き出すマクロの完成でござる
２つのシート共に、比較対象セル（UsedRange）が空白でないため上記のようなキレイな結果が出るのだが、例えば空白セルと文字入りのセルを比較した場合
先ほどの空白セルは無視するという処理がネックとなる
具体的には、差分があるにも関わらず片方のシートは塗られ、もう片方のシートは塗られないという現象が起こってしまう
まぁ、多少は仕方ないね
また、恐らくではあるがこの比較
「カタカナ」と「ひらがな」
「大文字」と「小文字」
の区別もできないはず
まぁ、多少は仕方ないね
気になる方は、以下のソースコードで試してみてくださいまし！
③ソースコード
Sub シート比較()
Dim SheetCnt As Long
Dim Sheet1Name As String
Dim Sheet2Name As String
For i = 1 To Worksheets.Count
SheetCnt = SheetCnt + 1
Next i
If SheetCnt <> 2 Then
MsgBox "シート数が不正です。終了します。"
Exit Sub
End If
Sheet1Name = Worksheets(1).Name
Sheet2Name = Worksheets(2).Name
Dim wksOld As Worksheet
Dim wksNew As Worksheet
Set wksOld = ActiveWorkbook.Sheets(Sheet1Name)
Set wksNew = ActiveWorkbook.Sheets(Sheet2Name)
Dim r As Range
Dim s As Range
Dim rngOld As Range
Dim rngNew As Range
Set rngOld = wksOld.UsedRange
Dim OldStr As String
Dim NewStr As String
Dim row As Long, col As Long
For Each r In rngOld
DoEvents
OldStr = r.Value
If Len(OldStr) > 0 Then
row = r.row
col = r.Column
Set rngNew = wksNew.Cells(row, col)
NewStr = rngNew.Value
If StrComp(OldStr, NewStr, vbTextCompare) <> 0 Then
rngNew.Interior.Color = RGB(255, 255, 0)
End If
End If
Next r
Set r = Nothing
Set rngOld = Nothing
Set rngNew = Nothing
OldStr = ""
NewStr = ""
row = 0
col = 0
Set rngNew = wksNew.UsedRange
For Each s In rngNew
DoEvents
NewStr = s.Value
If Len(NewStr) > 0 Then
row = s.row
col = s.Column
Set rngOld = wksOld.Cells(row, col)
OldStr = rngOld.Value
If StrComp(NewStr, OldStr, vbTextCompare) <> 0 Then
rngOld.Interior.Color = RGB(255, 255, 0)
End If
End If
Next s
MsgBox "比較処理が完了しました"
End Sub
Dim Sheet1Name As String
Dim Sheet2Name As String
For i = 1 To Worksheets.Count
SheetCnt = SheetCnt + 1
Next i
If SheetCnt <> 2 Then
MsgBox "シート数が不正です。終了します。"
Exit Sub
End If
Sheet1Name = Worksheets(1).Name
Sheet2Name = Worksheets(2).Name
Dim wksOld As Worksheet
Dim wksNew As Worksheet
Set wksOld = ActiveWorkbook.Sheets(Sheet1Name)
Set wksNew = ActiveWorkbook.Sheets(Sheet2Name)
Dim r As Range
Dim s As Range
Dim rngOld As Range
Dim rngNew As Range
Set rngOld = wksOld.UsedRange
Dim OldStr As String
Dim NewStr As String
Dim row As Long, col As Long
For Each r In rngOld
DoEvents
OldStr = r.Value
If Len(OldStr) > 0 Then
row = r.row
col = r.Column
Set rngNew = wksNew.Cells(row, col)
NewStr = rngNew.Value
If StrComp(OldStr, NewStr, vbTextCompare) <> 0 Then
rngNew.Interior.Color = RGB(255, 255, 0)
End If
End If
Next r
Set r = Nothing
Set rngOld = Nothing
Set rngNew = Nothing
OldStr = ""
NewStr = ""
row = 0
col = 0
Set rngNew = wksNew.UsedRange
For Each s In rngNew
DoEvents
NewStr = s.Value
If Len(NewStr) > 0 Then
row = s.row
col = s.Column
Set rngOld = wksOld.Cells(row, col)
OldStr = rngOld.Value
If StrComp(NewStr, OldStr, vbTextCompare) <> 0 Then
rngOld.Interior.Color = RGB(255, 255, 0)
End If
End If
Next s
MsgBox "比較処理が完了しました"
End Sub
