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
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
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
ToggleInterface False
Set wbOutput = Excel.Application.Workbooks.Add
Set wsOutput = GetOutputSheet(wbOutput)
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 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
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
|