趣味プログラミングblog

---

Option Explicit

Sub シート比較自動試験()
Const refSHname = "refSH" '比較対象シート名
If ActiveSheet.Name = refSHname Then msgEnd ("他のシートを選択して実行してください。")

'refSHnameシートがあるか判定
Dim sh As Long, rWS As Worksheet, tWS As Worksheet
For sh = 1 To Worksheets.Count
If Worksheets(sh).Name = refSHname Then
Set rWS = Worksheets(sh)
Set tWS = ActiveSheet
End If
Next sh

'２シート選択されてるか判定
If ActiveWindow.SelectedSheets.Count = 2 Then
Set rWS = ActiveWindow.SelectedSheets(1) '比較対象
Set tWS = ActiveWindow.SelectedSheets(2) 'test対象
ElseIf rWS Is Nothing Then
msgEnd ("２シート選択するか比較対象シート名を「 " & refSHname & " 」に変更してください。")
End If

'UsedRange比較と値の比較をして、結果を出力メッセージ用変数に格納
Dim uRangeDiff As Boolean, r As Variant, rValue As String, cnt As Long, rMsg As String
If tWS.UsedRange.Address <> rWS.UsedRange.Address Then
uRangeDiff = True
rMsg = "UsedRangeが異なります。" & Chr(10)
rMsg = rMsg & Chr(10)
rMsg = rMsg & tWS.Name & " 　 " & rWS.Name & Chr(10)
rMsg = rMsg & "[" & Replace(tWS.UsedRange.Address & "] ⇔ [" & rWS.UsedRange.Address, "$", "") & "]"
Else
For Each r In tWS.UsedRange
If tWS.range(r.Address).Value <> rWS.range(r.Address).Value Then
cnt = cnt + 1
rMsg = rMsg & Chr(10) & Replace(r.Address, "$", "") & " [" & tWS.range(r.Address) & "] ⇔ [" & rWS.range(r.Address) & "]"
End If
Next r
End If

'結果表示
If uRangeDiff = True Then
MsgBox rMsg, vbOKOnly, "範囲エラー"
ElseIf cnt > 0 Then
If cnt > 10 Then
MsgBox cnt & "箇所違います", vbOKOnly, "値エラー"
Else
MsgBox (cnt & "箇所違います" & Chr(10) & Chr(10) & "Range " & tWS.Name & " 　 " & rWS.Name & rMsg), vbOKOnly, "値エラー"
End If
Else
MsgBox rWS.Name & "と" & tWS.Name & "に相違点はありません"
End If
End Sub

Private Sub msgEnd(msg)
'メッセージを出して処理終了
MsgBox msg
End 'exit subじゃない
End Sub