リファクタリング用シート比較マクロの改良
2022年06月11日
前回、エクセルの計算誤差について投稿した。
表示が同じでも値が同じとは限らないということがあるので、
シート比較マクロも値とテキストそれぞれで比較する必要があるかも。
それと、範囲が違った場合も相違点を調べるために
具体的にどのセルがどう違うか知りたいので改良することにした。
レンジ比較、値比較、テキスト比較の３すそれぞれに
メッセージ変数を設定して、相違点がある場合に追記していく。
あんまり大量にメッセージだされてもうざいので、
差分を出力するのは２０箇所までにした。
UsedRangeが違うシートを比較する処理は
行列を比較してとか考えていたけど、
範囲 合体でぐぐったらUnionメソッドが使えるらしい。
https://www.sejuku.net/blog/88187
Union(rWS.UsedRange,tWS.UsedRange)だとエラーが出るので、
Union(range(rWS.UsedRange.address),range(tWS.UsedRange.address))に変更。
ん、Rangeでも同じことできるならこれでいいじゃん・・・。
range(rWS.UsedRange.Address, tWS.UsedRange.Address)
正式にはApplication.Union。だからunionメソッド。
https://excel-ubara.com/excelvba1/EXCELVBA403.html
一部のセルが重なる場合のアドレスがどうなるか見てみたら、
指定したままのアドレス表示になるのね。。。
案の定、for each r in union(・・・,・・・)で指定したら
重なった箇所は２回処理されてた。
セルのアドレスを辞書型配列に格納して、キーがなければ処理する仕様にした。
テストで作ったプロシージャは以下の通り。。
Sub unionTest()
Debug.Print Union(range("C122:F126"), range("B120:D123")).Address
Dim r As range, cnt As Long
Dim rDic: Set rDic = CreateObject("Scripting.Dictionary")
For Each r In Union(range("C122:F126"), range("B120:D123"))
If rDic.exists(r.Address) = False Then
rDic.Add r.Address, 1
cnt = cnt + 1
End If
Next r
Debug.Print cnt
End Sub
以下、ソース。 ダウンロード
表示が同じでも値が同じとは限らないということがあるので、
シート比較マクロも値とテキストそれぞれで比較する必要があるかも。
それと、範囲が違った場合も相違点を調べるために
具体的にどのセルがどう違うか知りたいので改良することにした。
レンジ比較、値比較、テキスト比較の３すそれぞれに
メッセージ変数を設定して、相違点がある場合に追記していく。
あんまり大量にメッセージだされてもうざいので、
差分を出力するのは２０箇所までにした。
UsedRangeが違うシートを比較する処理は
行列を比較してとか考えていたけど、
範囲 合体でぐぐったらUnionメソッドが使えるらしい。
https://www.sejuku.net/blog/88187
Union(rWS.UsedRange,tWS.UsedRange)だとエラーが出るので、
Union(range(rWS.UsedRange.address),range(tWS.UsedRange.address))に変更。
ん、Rangeでも同じことできるならこれでいいじゃん・・・。
range(rWS.UsedRange.Address, tWS.UsedRange.Address)
正式にはApplication.Union。だからunionメソッド。
https://excel-ubara.com/excelvba1/EXCELVBA403.html
一部のセルが重なる場合のアドレスがどうなるか見てみたら、
指定したままのアドレス表示になるのね。。。
案の定、for each r in union(・・・,・・・)で指定したら
重なった箇所は２回処理されてた。
セルのアドレスを辞書型配列に格納して、キーがなければ処理する仕様にした。
テストで作ったプロシージャは以下の通り。。
Sub unionTest()
Debug.Print Union(range("C122:F126"), range("B120:D123")).Address
Dim r As range, cnt As Long
Dim rDic: Set rDic = CreateObject("Scripting.Dictionary")
For Each r In Union(range("C122:F126"), range("B120:D123"))
If rDic.exists(r.Address) = False Then
rDic.Add r.Address, 1
cnt = cnt + 1
End If
Next r
Debug.Print cnt
End Sub
以下、ソース。 ダウンロード
Option Explicit
Const debugFlag = 0
Sub compareSH()
Call シート比較自動試験
End Sub
'アクティブシートとrefシートをvalueとtextで比較
Sub シート比較自動試験(Optional refSHname As String = "ref")
Dim tictoc As Double: tictoc = Timer
'refSHname のシートがあるか判定。あればrWSに格納
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 & " 」に変更してください。")
ElseIf ActiveSheet.Name = refSHname Then
msgEnd ("他のシートを選択して実行してください。")
End If
'UsedRange比較と値の比較をして、結果を出力メッセージ用変数に格納
Dim uRangeDiff As Boolean, r As Variant, rValue As String, vCnt As Long, tCnt As Long
Dim rMsg As String, vMsg As String, tMsg As String
Dim rDic: Set rDic = CreateObject("Scripting.Dictionary")
If tWS.UsedRange.Address <> rWS.UsedRange.Address Then
uRangeDiff = True
rMsg = "UsedRangeが異なります。" & Chr(10)
rMsg = rMsg & Chr(10)
rMsg = rMsg & rWS.Name & " " & tWS.Name & Chr(10)
rMsg = rMsg & "[" & Replace(rWS.UsedRange.Address & "] ⇔ [" & tWS.UsedRange.Address, "$", "") & "]"
'Else '(UsedRangeが同じなら)20個まで比較結果を格納
For Each r In range(rWS.UsedRange.Address, tWS.UsedRange.Address)
If rDic.exists(r.Address) = False Then
rDic.Add r.Address, 1
If tWS.range(r.Address).Value <> rWS.range(r.Address).Value Then '値比較
vCnt = vCnt + 1
If vCnt < 20 Then
vMsg = vMsg & Chr(10) & Replace(r.Address, "$", "") & " [" & rWS.range(r.Address).Value & "] ⇔ [" & tWS.range(r.Address).Value & "]"
ElseIf vCnt = 20 Then
vMsg = vMsg & Chr(10) & "以下省略"
End If
End If
If tWS.range(r.Address).text <> rWS.range(r.Address).text Then '文字比較
tCnt = tCnt + 1
If tCnt < 20 Then
tMsg = tMsg & Chr(10) & Replace(r.Address, "$", "") & " [" & rWS.range(r.Address).text & "] ⇔ [" & tWS.range(r.Address).text & "]"
ElseIf tCnt = 20 Then
tMsg = tMsg & Chr(10) & "以下省略"
End If
End If
End If
Next r
End If
If debugFlag = 1 Then Debug.Print "シート比較[" & Now & "] "; Format(Timer - tictoc, "0.00秒")
'結果表示
If uRangeDiff = True Then
MsgBox rMsg, vbOKOnly, "範囲エラー"
'Exit Sub
End If
If vCnt > 0 Then MsgBox ("値ベースで" & vCnt & "箇所違います" & Chr(10) & Chr(10) & "セル " & rWS.Name & " " & tWS.Name & vMsg), vbOKOnly, "値エラー"
If tCnt > 0 Then MsgBox ("表示ベースで" & tCnt & "箇所違います" & Chr(10) & Chr(10) & "セル " & rWS.Name & " " & tWS.Name & tMsg), vbOKOnly, "表示エラー"
If vCnt + tCnt = 0 Then
Dim msg As String: msg = rWS.Name & "と" & tWS.Name & "に相違点はありません。"
MsgBox msg
End If
Application.DisplayAlerts = False
If MsgBox("結果シートを削除しますか？", vbYesNo, "シート削除確認") = vbYes Then ActiveSheet.Delete
Application.DisplayAlerts = False
End Sub
Private Sub msgEnd(msg)
'メッセージを出して処理終了
MsgBox msg
End 'exit subじゃない
End Sub
PR
Comment