Option Explicit
Private Type Cell
Value As String
Address As String
End Type
Private Const abRange1Address As Long = 1
Private Const abRange1Value As Long = 2
Private Const abRange2Address As Long = 3
Private Const abRange2Value As Long = 4
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 Long
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
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
Err.Raise lngErrCncl_c, strProcedureName_c, strErrCncl_c
End If
lngUprBndRow = rng1.Rows.Count
If lngUprBndRow <> rng2.Rows.Count Then
Err.Raise lngErrRngMismatch_c, strProcedureName_c, strErrRngMismatch_c
Else
lngUprBndClmn = rng1.Columns.Count
If lngUprBndClmn <> rng2.Columns.Count Then
Err.Raise lngErrRngMismatch_c, strProcedureName_c, _
strErrRngMismatch_c
End If
End If
''-----------------------------------------------------------------------------------
''Prompt User regarding case sensitivity:--------------------------------------------
''-----------------------------------------------------------------------------------
Select Case MsgBox("Do you want a case-sensitive comparison?", _
vbYesNoCancel + vbQuestion + vbSystemModal + vbDefaultButton2 + _
vbMsgBoxSetForeground, "Decide Comparison Type")
Case vbCancel
Err.Raise lngErrCncl_c, strProcedureName_c, strErrCncl_c
Case vbYes
eCompareType = vbBinaryCompare
Case 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 LenB(tVal1.Value) = LenB(tVal2.Value) Then
'If the lengths are the same, then values may still be different.
If StrComp(tVal1.Value, tVal2.Value, eCompareType) <> _
lngMatch_c Then
lngOutputRow = lngOutputRow + lngIncrement_c
wsOutput.Cells(lngOutputRow, abRange1Address).Value = _
strFrcTxt_c & strWs1Name & tVal1.Address
wsOutput.Cells(lngOutputRow, abRange1Value).Value = _
strFrcTxt_c & tVal1.Value
wsOutput.Cells(lngOutputRow, abRange2Address).Value = _
strFrcTxt_c & strWs2Name & tVal2.Address
wsOutput.Cells(lngOutputRow, 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, abRange1Address).Value = _
strFrcTxt_c & strWs1Name & tVal1.Address
wsOutput.Cells(lngOutputRow, abRange1Value).Value = strFrcTxt_c _
& tVal1.Value
wsOutput.Cells(lngOutputRow, abRange2Address).Value = _
strFrcTxt_c & strWs2Name & tVal2.Address
wsOutput.Cells(lngOutputRow, 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 Err.Number = lngErrCncl_c Then
Resume Exit_Proc
ElseIf Err.Number = lngErrIntrpt_c Then
MsgBox "Operation Cancelled", vbOKOnly + vbMsgBoxSetForeground + _
vbSystemModal
Else
MsgBox Err.Description, vbCritical + vbMsgBoxHelpButton + _
vbMsgBoxSetForeground + vbSystemModal, strTitleError_c & Err.Number, _
Err.HelpFile, 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, abRange1Address) = "Range1 Address"
wsOutput.Cells(lngOne_c, abRange1Value) = "Range1 Value"
wsOutput.Cells(lngOne_c, abRange2Address) = "Range2 Address"
wsOutput.Cells(lngOne_c, 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
Reply With Quote
Originally Posted by GTO
