VBA to compare data on two sheets and create an exceptions report on the third

Hi everyone,

I am trying to code a macro that would allow me to compare infomation in two separate worksheets and create a third worksheet with the exceptions listed. A few things to note:

1) The information to be compared will be displayed in the form of data tapes with a set number of columns in Sheet1. This will be compared to a data tape in Sheet2 also with the same number of columns and identical headers, but with a variable number of rows of data.
2) The rows within the datatapes will be identified based on unique ID numbers in both sheets. Thus for example, ID 1 can be in Sheet 1, row 5, which will have to be compared to ID 1, which can be in row 11 (or any other ones) in Sheet2.
3) All differences with be reported in a exceptions report in a Sheet3 of the same file.
4) In terms of formatting, I will need to design an initial user form that will give me the option of choosing whether the numbers being compared are based on the actual number in the cell, or the number displayed.

I am quite the newbie in VBA but have had minor experience. Looked at various other similar codes but can't find what I am exactly seeking. Any pointers would be most helpful.


Thank you in advance.

-NC

Hi again,

Came across an excellent code to fulfill what I need. The only issue being how the information is displayed in the third sheet. Instead of rows, I would like the changes to be represented in columns. Therefore, it would be - Type of Change (if any), Sheet 1, Sheet 2. Any pointers anyone??


Option Explicit
Dim miMaxColumns As Integer
Sub CompareSheets()
Dim bChanged As Boolean, baChanged() As Boolean
Dim iColEnd As Integer, iCol As Integer, iCol1 As Integer, iCol2 As Integer
Dim lRow1 As Long, lRow2 As Long, lReportRow As Long
Dim objDictOld As Object, objDictNew As Object
Dim vKeys As Variant, vKey As Variant
Dim vaInput() As Variant, vaOutput() As Variant, vaOutput2() As Variant
Dim vaInputOld As Variant, vaInputNew As Variant
Dim wsOld As Worksheet, wsNew As Worksheet, wsReport As Worksheet


Set wsOld = Sheets("Sheet1")
miMaxColumns = wsOld.Cells(1, Columns.Count).End(xlToLeft).Column
Set objDictOld = PopulateDictionary(WS:=wsOld)
Set wsNew = Sheets("Sheet2")
Set objDictNew = PopulateDictionary(WS:=wsNew)

Set wsReport = Sheets("Sheet3")

With wsReport
.Cells.ClearFormats
.Cells.ClearContents
End With

wsOld.Range("A1:" & wsOld.Cells(1, miMaxColumns).Address).Copy
wsReport.Range("B1").PasteSpecial xlPasteValues
Application.CutCopyMode = False

lReportRow = 1
vKeys = objDictOld.Keys
For Each vKey In vKeys
ReDim vaInputOld(1 To 1, 1 To miMaxColumns)
vaInputOld = objDictOld.Item(vKey)
If objDictNew.exists(vKey) Then
ReDim vaInputNew(1 To 1, 1 To miMaxColumns)
vaInputNew = objDictNew.Item(vKey)
ReDim vaOutput(1 To 1, 1 To miMaxColumns + 1)
ReDim vaOutput2(1 To 1, 1 To miMaxColumns + 1)
ReDim baChanged(1 To miMaxColumns)
bChanged = False
For iCol = 1 To miMaxColumns
vaOutput(1, iCol + 1) = vaInputOld(1, iCol)
If vaInputOld(1, iCol) <> vaInputNew(1, iCol) Then
vaOutput2(1, iCol + 1) = vaInputNew(1, iCol)
baChanged(iCol) = True
bChanged = True
End If
Next iCol
If bChanged Then
lReportRow = lReportRow + 1
For iCol = 1 To UBound(baChanged)
If baChanged(iCol) Then
With wsReport
.Range(.Cells(lReportRow, iCol + 1).Address, _
.Cells(lReportRow + 1, iCol + 1).Address).Interior.Color = vbYellow
End With
End If
Next iCol

vaOutput(1, 1) = "Changed"
With wsReport
.Range(.Cells(lReportRow, 1).Address, _
.Cells(lReportRow, miMaxColumns + 1).Address).Value = vaOutput
lReportRow = lReportRow + 1
.Range(.Cells(lReportRow, 1).Address, _
.Cells(lReportRow, miMaxColumns + 1).Address).Value = vaOutput2
End With
End If
objDictOld.Remove vKey
objDictNew.Remove vKey
Else
ReDim vaOutput(1 To 1, 1 To miMaxColumns + 1)
vaOutput(1, 1) = "Deleted"
For iCol = 1 To miMaxColumns
vaOutput(1, iCol + 1) = vaInputOld(1, iCol)
Next iCol

lReportRow = lReportRow + 1
With wsReport
.Range(.Cells(lReportRow, 1).Address, .Cells(lReportRow, miMaxColumns + 1).Address).Value = vaOutput
'-- Set the row to light grey
.Range(.Cells(lReportRow, 2).Address, .Cells(lReportRow, miMaxColumns + 1).Address).Interior.ColorIndex = 15
End With
End If
Next vKey

If objDictNew.Count <> 0 Then
vKeys = objDictNew.Keys
For Each vKey In vKeys
ReDim vaOutput2(1 To 1, 1 To miMaxColumns + 1)
vaInputNew = objDictNew.Item(vKey)
vaOutput2(1, 1) = "Inserted"
For iCol = 1 To miMaxColumns
vaOutput2(1, iCol + 1) = vaInputNew(1, iCol)
Next iCol
lReportRow = lReportRow + 1
With wsReport
.Range(.Cells(lReportRow, 1).Address, .Cells(lReportRow, miMaxColumns + 1).Address).Value = vaOutput2
'-- Set the row to light green
.Range(.Cells(lReportRow, 2).Address, .Cells(lReportRow, miMaxColumns + 1).Address).Interior.ColorIndex = 4
End With
Next vKey
End If

objDictOld.RemoveAll
Set objDictOld = Nothing
objDictNew.RemoveAll
Set objDictNew = Nothing
End Sub
Private Function PopulateDictionary(ByRef WS As Worksheet) As Object
Dim lRowEnd As Long, lRow As Long
Dim rCur As Range
Dim sKey As String

Set PopulateDictionary = Nothing
Set PopulateDictionary = CreateObject("Scripting.Dictionary")
lRowEnd = WS.Cells(Rows.Count, "A").End(xlUp).Row
For lRow = 2 To lRowEnd
sKey = Trim$(LCase$(CStr(WS.Range("A" & lRow).Value)))
On Error Resume Next
PopulateDictionary.Add Key:=sKey, Item:=WS.Range(WS.Cells(lRow, 1).Address, _
WS.Cells(lRow, miMaxColumns).Address).Value
On Error GoTo 0
Next lRow
End Function

Hi ***,
I found an issue in the above given macro.

Steps to find the issue.
1. Keep the same records in sheet 1 and sheet 2
2. Copy and paste the last row in two sheets.
3. Change the value in sheet 2 in the pasted cell except the first column.
4. Now run the macro.

It is not displaying the value in the Changed header. Please help me.