Attribute VB_Name = "RefactoringTool_v10r01"
Option Explicit
Const debugFlag = 0

Sub compareSH()
    Call シート比較自動試験
End Sub

'アクティブシートとrefシートをvalueとtextで比較
Sub シート比較自動試験(Optional refSHname As String = "ref")
    If IsMissing(refSHname) Then refSHname = "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, "$", "") & "]"
    End If ' 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


Function compareArr(Arr1, Arr2)
    If UBound(Arr1, 1) <> UBound(Arr2, 1) Then compareArr = "size Error Ubound1"
    If UBound(Arr1, 2) <> UBound(Arr2, 2) Then compareArr = "size Error Ubound2"
    Dim i As Long, j As Long, cnt
    For i = 0 To UBound(Arr1, 1)
        For j = 0 To UBound(Arr1, 2)
            If Arr1(i, j) <> Arr2(i, j) Then cnt = cnt + 1
        Next j
    Next i
    If cnt <> 0 Then
        compareArr = "Value Error :" & cnt
    Else
        compareArr = "Match"
    End If
End Function