itipu
11-15-2017, 08:42 PM
Greetings All,
So I was trying to develop a bit of code to compare two spreadsheets in a workbook - doesn't have to be pretty. I managed to write a bit of code that does that on a line by line basis, however this is not exactly what I am looking for.
Ideally what I am looking for is a comparison based on a key value in Column I (this is a unique value). So if the ColumnI.Value is found in both sheets, a comparison is done of that row, and it shows what cell values changed in that row. If the ColumnI.Value is only found in Sheet1 Column I but not in Sheet2 Column I - it highlights this row was deleted, if the ColumnI.Value is found in Sheet2 Column I only, it highlights this row was added.
Spreadsheet with code is attached, your help as always would be grately appreciated.
Sub TestCompareWorksheets()
CompareWorksheets Worksheets("Sheet1"), Worksheets("Sheet2")
End Sub
Sub CompareWorksheets(ws1 As Worksheet, ws2 As Worksheet)
Dim r As Long, c As Integer
Dim lr1 As Long, lr2 As Long, lc1 As Integer, lc2 As Integer
Dim maxR As Long, maxC As Integer, cf1 As String, cf2 As String
Dim rptWB As Workbook, DiffCount As Long
Application.ScreenUpdating = False
Application.StatusBar = "Creating the report..."
Set rptWB = Workbooks.Add
Application.DisplayAlerts = False
Application.DisplayAlerts = True
With ws1.UsedRange
lr1 = .Rows.Count
lc1 = .Columns.Count
End With
With ws2.UsedRange
lr2 = .Rows.Count
lc2 = .Columns.Count
End With
maxR = lr1
maxC = lc1
If maxR < lr2 Then maxR = lr2
If maxC < lc2 Then maxC = lc2
DiffCount = 0
For c = 1 To maxC
Application.StatusBar = "Comparing cells " & Format(c / maxC, "0 %") & "..."
For r = 1 To maxR
cf1 = ""
cf2 = ""
On Error Resume Next
cf1 = ws1.Cells(r, c).FormulaLocal
cf2 = ws2.Cells(r, c).FormulaLocal
On Error GoTo 0
If cf1 <> cf2 Then
DiffCount = DiffCount + 1
Cells(r, c).Formula = "'" & cf1 & " <> " & cf2
End If
Next r
Next c
Application.StatusBar = "Formatting the report..."
With Range(Cells(1, 1), Cells(maxR, maxC))
.Interior.ColorIndex = 19
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
On Error Resume Next
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
On Error GoTo 0
End With
Columns("A:IV").ColumnWidth = 20
rptWB.Saved = True
If DiffCount = 0 Then
rptWB.Close False
End If
Set rptWB = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox DiffCount & " cells contain different details!", vbInformation, _
"Compare " & ws1.Name & " with " & ws2.Name
End Sub
I also thought this might work, and it identifies changes nicely, but I can't figure how to get it to highlight deletions/additions to the sheets.
Option Explicit
Sub Compare3()
Dim rDatabase As Range, rFile As Range
Dim iFile As Long, iDatabase As Long, iColumn As Long
Set rDatabase = Worksheets("Sheet1").Cells(1, 1).CurrentRegion
Set rFile = Worksheets("Sheet2").Cells(1, 1).CurrentRegion
rFile.Interior.Color = xlNone
rDatabase.Interior.Color = xlNone
For iFile = 2 To rFile.Rows.Count
iDatabase = -1
On Error Resume Next
iDatabase = Application.WorksheetFunction.Match(rFile.Cells(iFile, 9).Value, rDatabase.Columns(9), 0)
On Error GoTo 0
If iDatabase <> -1 Then
For iColumn = 2 To rFile.Columns.Count
' changed to add CStr()'s
If CStr(rFile.Cells(iFile, iColumn).Value) <> CStr(rDatabase.Cells(iDatabase, iColumn).Value) Then
rFile.Cells(iFile, iColumn).Interior.Color = vbRed
End If
Next iColumn
End If
Next iFile
For iDatabase = 2 To rDatabase.Rows.Count
iFile = -1
On Error Resume Next
iFile = Application.WorksheetFunction.Match(rDatabase.Cells(iDatabase, 9).Value, rFile.Columns(9), 0)
On Error GoTo 0
If iFile <> -1 Then
For iColumn = 2 To rDatabase.Columns.Count
' changed to add CStr()'s
If CStr(rDatabase.Cells(iDatabase, iColumn).Value) <> CStr(rFile.Cells(iFile, iColumn).Value) Then
rDatabase.Cells(iDatabase, iColumn).Interior.Color = vbYellow
End If
Next iColumn
End If
Next iDatabase
End Sub
So I was trying to develop a bit of code to compare two spreadsheets in a workbook - doesn't have to be pretty. I managed to write a bit of code that does that on a line by line basis, however this is not exactly what I am looking for.
Ideally what I am looking for is a comparison based on a key value in Column I (this is a unique value). So if the ColumnI.Value is found in both sheets, a comparison is done of that row, and it shows what cell values changed in that row. If the ColumnI.Value is only found in Sheet1 Column I but not in Sheet2 Column I - it highlights this row was deleted, if the ColumnI.Value is found in Sheet2 Column I only, it highlights this row was added.
Spreadsheet with code is attached, your help as always would be grately appreciated.
Sub TestCompareWorksheets()
CompareWorksheets Worksheets("Sheet1"), Worksheets("Sheet2")
End Sub
Sub CompareWorksheets(ws1 As Worksheet, ws2 As Worksheet)
Dim r As Long, c As Integer
Dim lr1 As Long, lr2 As Long, lc1 As Integer, lc2 As Integer
Dim maxR As Long, maxC As Integer, cf1 As String, cf2 As String
Dim rptWB As Workbook, DiffCount As Long
Application.ScreenUpdating = False
Application.StatusBar = "Creating the report..."
Set rptWB = Workbooks.Add
Application.DisplayAlerts = False
Application.DisplayAlerts = True
With ws1.UsedRange
lr1 = .Rows.Count
lc1 = .Columns.Count
End With
With ws2.UsedRange
lr2 = .Rows.Count
lc2 = .Columns.Count
End With
maxR = lr1
maxC = lc1
If maxR < lr2 Then maxR = lr2
If maxC < lc2 Then maxC = lc2
DiffCount = 0
For c = 1 To maxC
Application.StatusBar = "Comparing cells " & Format(c / maxC, "0 %") & "..."
For r = 1 To maxR
cf1 = ""
cf2 = ""
On Error Resume Next
cf1 = ws1.Cells(r, c).FormulaLocal
cf2 = ws2.Cells(r, c).FormulaLocal
On Error GoTo 0
If cf1 <> cf2 Then
DiffCount = DiffCount + 1
Cells(r, c).Formula = "'" & cf1 & " <> " & cf2
End If
Next r
Next c
Application.StatusBar = "Formatting the report..."
With Range(Cells(1, 1), Cells(maxR, maxC))
.Interior.ColorIndex = 19
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
On Error Resume Next
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
On Error GoTo 0
End With
Columns("A:IV").ColumnWidth = 20
rptWB.Saved = True
If DiffCount = 0 Then
rptWB.Close False
End If
Set rptWB = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox DiffCount & " cells contain different details!", vbInformation, _
"Compare " & ws1.Name & " with " & ws2.Name
End Sub
I also thought this might work, and it identifies changes nicely, but I can't figure how to get it to highlight deletions/additions to the sheets.
Option Explicit
Sub Compare3()
Dim rDatabase As Range, rFile As Range
Dim iFile As Long, iDatabase As Long, iColumn As Long
Set rDatabase = Worksheets("Sheet1").Cells(1, 1).CurrentRegion
Set rFile = Worksheets("Sheet2").Cells(1, 1).CurrentRegion
rFile.Interior.Color = xlNone
rDatabase.Interior.Color = xlNone
For iFile = 2 To rFile.Rows.Count
iDatabase = -1
On Error Resume Next
iDatabase = Application.WorksheetFunction.Match(rFile.Cells(iFile, 9).Value, rDatabase.Columns(9), 0)
On Error GoTo 0
If iDatabase <> -1 Then
For iColumn = 2 To rFile.Columns.Count
' changed to add CStr()'s
If CStr(rFile.Cells(iFile, iColumn).Value) <> CStr(rDatabase.Cells(iDatabase, iColumn).Value) Then
rFile.Cells(iFile, iColumn).Interior.Color = vbRed
End If
Next iColumn
End If
Next iFile
For iDatabase = 2 To rDatabase.Rows.Count
iFile = -1
On Error Resume Next
iFile = Application.WorksheetFunction.Match(rDatabase.Cells(iDatabase, 9).Value, rFile.Columns(9), 0)
On Error GoTo 0
If iFile <> -1 Then
For iColumn = 2 To rDatabase.Columns.Count
' changed to add CStr()'s
If CStr(rDatabase.Cells(iDatabase, iColumn).Value) <> CStr(rFile.Cells(iFile, iColumn).Value) Then
rDatabase.Cells(iDatabase, iColumn).Interior.Color = vbYellow
End If
Next iColumn
End If
Next iDatabase
End Sub