Option Explicit 
Private Type Cell 
    Value As String 
    Address As String 
End Type 
Private Enum abOutputColumns 
    abRange1Address = 1 
    abRange1Value 
    abRange2Address 
    abRange2Value 
End Enum 
 
Public Sub OutputDifferences() 
    On Error GoTo Err_Hnd 
    Const strProcedureName_c As String = "AnalyzeDifferences" 
    Const strTitleSelectRange_c As String = "Select Range" 
    Const strTitleError_c As String = "Error: " 
    Const lngErrRngMismatch_c As Long = vbObjectError + 513 
    Const lngErrCncl_c As Long = vbObjectError + 777 
    Const lngErrIntrpt_c As Long = 18 
    Const strErrRngMismatch_c As String = "The ranges you have selected are not equivilant. Selected ranges must have the same number of rows and the same number of columns." 
    Const strErrCncl_c As String = "Procedure cancelled." 
    Const lngMatch_c As Long = 0 
    Const lngLwrBnd_c As Long = 1 
    Const strFrcTxt_c As String = "'" 
    Const lngIncrement_c As Long = lngLwrBnd_c 
    Const strBang_c As String = "!" 
    Dim rng1 As Excel.Range 
    Dim rng2 As Excel.Range 
    Dim wbOutput As Excel.Workbook 
    Dim wsOutput As Excel.Worksheet 
    Dim lngRow As Long 
    Dim lngClmn As Long 
    Dim lngUprBndRow As Long 
    Dim lngUprBndClmn As Long 
    Dim lngOutputRow As Long 
    Dim strWs1Name As String 
    Dim strWs2Name As String 
    Dim eCompareType As VbCompareMethod 
    Dim tVal1 As Cell 
    Dim tVal2 As Cell 
     ''-----------------------------------------------------------------------------------
     ''Select Ranges to Compare:----------------------------------------------------------
     ''-----------------------------------------------------------------------------------
    Set rng1 = GetRange("Please use mouse to select First Range:", strTitleSelectRange_c) 
    If rng1 Is Nothing Then 
        VBA.Err.Raise lngErrCncl_c, strProcedureName_c, strErrCncl_c 
    End If 
    Set rng2 = GetRange("Please use mouse to select the Second Range:", strTitleSelectRange_c) 
    If rng2 Is Nothing Then 
        VBA.Err.Raise lngErrCncl_c, strProcedureName_c, strErrCncl_c 
    End If 
    lngUprBndRow = rng1.Rows.Count 
    If lngUprBndRow <> rng2.Rows.Count Then 
        VBA.Err.Raise lngErrRngMismatch_c, strProcedureName_c, strErrRngMismatch_c 
    Else 
        lngUprBndClmn = rng1.Columns.Count 
        If lngUprBndClmn <> rng2.Columns.Count Then 
            VBA.Err.Raise lngErrRngMismatch_c, strProcedureName_c, strErrRngMismatch_c 
        End If 
    End If 
     ''-----------------------------------------------------------------------------------
     ''Prompt User regarding case sensitivity:--------------------------------------------
     ''-----------------------------------------------------------------------------------
    Select Case VBA.MsgBox("Do you want a case-sensitive comparison?", vbYesNoCancel + vbQuestion + vbSystemModal + vbDefaultButton2 + vbMsgBoxSetForeground, "Decide Comparison Type") 
    Case VbMsgBoxResult.vbCancel 
        VBA.Err.Raise lngErrCncl_c, strProcedureName_c, strErrCncl_c 
    Case VbMsgBoxResult.vbYes 
        eCompareType = vbBinaryCompare 
    Case VbMsgBoxResult.vbNo 
        eCompareType = vbTextCompare 
    End Select 
     ''===================================================================================
     
     ''-----------------------------------------------------------------------------------
     'All dialogs have concluded, disable interface for quicker execution:----------------
     ''-----------------------------------------------------------------------------------
    ToggleInterface False 
     ''===================================================================================
     
     ''-----------------------------------------------------------------------------------
     ''Create Output worksheet:-----------------------------------------------------------
     ''-----------------------------------------------------------------------------------
    Set wbOutput = Excel.Application.Workbooks.Add 
    Set wsOutput = GetOutputSheet(wbOutput) 
     ''===================================================================================
     
     ''-----------------------------------------------------------------------------------
     ''Create Output worksheet:-----------------------------------------------------------
     ''-----------------------------------------------------------------------------------
    strWs1Name = rng1.Parent.Name & strBang_c 
    strWs2Name = rng2.Parent.Name & strBang_c 
    lngOutputRow = lngIncrement_c 
     ''===================================================================================
     
     
    For lngRow = lngLwrBnd_c To lngUprBndRow 
        For lngClmn = lngLwrBnd_c To lngUprBndClmn 
            tVal1.Value = CStr(rng1.Cells(lngRow, lngClmn).Value) 
            tVal1.Address = CStr(rng1.Cells(lngRow, lngClmn).Address) 
            tVal2.Value = CStr(rng2.Cells(lngRow, lngClmn).Value) 
            tVal2.Address = CStr(rng2.Cells(lngRow, lngClmn).Address) 
            If VBA.LenB(tVal1.Value) = VBA.LenB(tVal2.Value) Then 
                 'If the lengths are the same, then values may still be different.
                If VBA.StrComp(tVal1.Value, tVal2.Value, eCompareType) <> lngMatch_c Then 
                    lngOutputRow = lngOutputRow + lngIncrement_c 
                    wsOutput.Cells(lngOutputRow, abOutputColumns.abRange1Address).Value = strFrcTxt_c & strWs1Name & tVal1.Address 
                    wsOutput.Cells(lngOutputRow, abOutputColumns.abRange1Value).Value = strFrcTxt_c & tVal1.Value 
                    wsOutput.Cells(lngOutputRow, abOutputColumns.abRange2Address).Value = strFrcTxt_c & strWs2Name & tVal2.Address 
                    wsOutput.Cells(lngOutputRow, abOutputColumns.abRange2Value).Value = strFrcTxt_c & tVal2.Value 
                End If 
            Else 
                 'If the lengths are not the same, then it is a given the values are different.
                lngOutputRow = lngOutputRow + lngIncrement_c 
                wsOutput.Cells(lngOutputRow, abOutputColumns.abRange1Address).Value = strFrcTxt_c & strWs1Name & tVal1.Address 
                wsOutput.Cells(lngOutputRow, abOutputColumns.abRange1Value).Value = strFrcTxt_c & tVal1.Value 
                wsOutput.Cells(lngOutputRow, abOutputColumns.abRange2Address).Value = strFrcTxt_c & strWs2Name & tVal2.Address 
                wsOutput.Cells(lngOutputRow, abOutputColumns.abRange2Value).Value = strFrcTxt_c & tVal2.Value 
            End If 
        Next 
    Next 
    wsOutput.Columns.AutoFit 
Exit_Proc: 
    On Error Resume Next 
    ToggleInterface True 
    Exit Sub 
Err_Hnd: 
    If VBA.Err.Number = lngErrCncl_c Then 
        Resume Exit_Proc 
    ElseIf VBA.Err.Number = lngErrIntrpt_c Then 
        VBA.MsgBox "Operation Cancelled", vbOKOnly + vbMsgBoxSetForeground + vbSystemModal 
    Else 
        VBA.MsgBox VBA.Err.Description, vbCritical + vbMsgBoxHelpButton + vbMsgBoxSetForeground + vbSystemModal, strTitleError_c & VBA.Err.Number, VBA.Err.HelpFile, VBA.Err.HelpContext 
    End If 
    On Error Resume Next 
    If Not wbOutput Is Nothing Then 
        wbOutput.Close False 
    End If 
    GoTo Exit_Proc 
End Sub 
 
Private Function GetRange(Prompt As String, Title As String) As Excel.Range 
    On Error Resume Next 
    Const lngRange_c As Long = 8 
    Set GetRange = Excel.Application.InputBox(Prompt, Title, Type:=lngRange_c) 
End Function 
 
Private Function GetOutputSheet(TargetWorkbook As Excel.Workbook) As Excel.Worksheet 
    Const lngOne_c As Long = 1 
    Dim wsOutput As Excel.Worksheet 
    Do Until TargetWorkbook.Worksheets.Count = lngOne_c 
        TargetWorkbook.Worksheets(lngOne_c).Delete 
    Loop 
    Set wsOutput = TargetWorkbook.Worksheets(lngOne_c) 
    wsOutput.Name = "Mismatched Cells" 
    wsOutput.Cells(lngOne_c, abOutputColumns.abRange1Address) = "Range1 Address" 
    wsOutput.Cells(lngOne_c, abOutputColumns.abRange1Value) = "Range1 Value" 
    wsOutput.Cells(lngOne_c, abOutputColumns.abRange2Address) = "Range2 Address" 
    wsOutput.Cells(lngOne_c, abOutputColumns.abRange2Value) = "Range2 Value" 
    Set GetOutputSheet = wsOutput 
End Function 
Private Sub ToggleInterface(InterfaceEnabled As Boolean) 
    Dim oApp As Excel.Application 
    Set oApp = Excel.Application 
    If InterfaceEnabled Then 
        oApp.Cursor = xlDefault 
    Else 
        oApp.Cursor = xlWait 
    End If 
    oApp.DisplayAlerts = InterfaceEnabled 
    oApp.ScreenUpdating = InterfaceEnabled 
    oApp.EnableEvents = InterfaceEnabled 
    If InterfaceEnabled Then 
        oApp.EnableCancelKey = xlInterrupt 
    Else 
        oApp.EnableCancelKey = xlErrorHandler 
    End If 
End Sub