Any help to tweak the following code much appreciated

[Millertant]

Hi all, the following I picked up elsewhere and have tweaked for my own purposes. Currently it compares two sheets in a workbook and creates a report of the differences between the two (I use it to compare a dump from a DB on a weekly basis to see if any naughty users have been messing around with the dataset) in an entirely new workbook and does it rather well. What I would like to do is tweak to create the report in another sheet in the original book. I also plan to add a load of formatting but this is less of a technical challange. Brace yourselves for long speil of code...

[VBA] 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
While rptWB.Worksheets.Count > 1
rptWB.Worksheets(2).Delete
Wend
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 formulas!", vbInformation, _
"Compare " & ws1.Name & " with " & ws2.Name
End Sub

Sub RunCompareWorksheets()
' compare two different worksheets in the active workbook
MsgBox ("Run Compare sheets?")
FirstWeek = InputBox("Enter name of first dump", "Required")
SecondWeek = InputBox("Enter name of second dump", "Required")
CompareWorksheets Worksheets(FirstWeek), Worksheets(SecondWeek)
End Sub[/VBA]

[Oorang]

Give this a whack.
[vba]Option Explicit

Private 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 DiffCount As Long, ws3 As Worksheet
Application.ScreenUpdating = False
Application.StatusBar = "Creating the report..."
Set ws3 = ws1.Parent.Worksheets.Add(Before:=ws1)
ws3.Name = "Output"
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
ws3.Cells(r, c).Formula = "'" & cf1 & " <> " & cf2
End If
Next r
Next c
Application.StatusBar = "Formatting the report..."
With ws3.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
ws3.Columns("A:IV").ColumnWidth = 20
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox DiffCount & " cells contain different formulas!", vbInformation, _
"Compare " & ws1.Name & " with " & ws2.Name
End Sub

Public Sub RunCompareWorksheets()
Const lCancelled_c As Long = 0
Dim FirstWeek As String
Dim SecondWeek As String
' compare two different worksheets in the active workbook
If VBA.MsgBox("Run Compare sheets?", vbQuestion + vbYesNo) = vbNo Then Exit Sub
FirstWeek = InputBox("Enter name of first dump", "Required", Excel.ActiveWorkbook.Worksheets(1).Name)
If VBA.LenB(FirstWeek) = lCancelled_c Then Exit Sub
SecondWeek = InputBox("Enter name of second dump", "Required", Excel.ActiveWorkbook.Worksheets(Excel.ActiveWorkbook.Worksheets.Count).Name )
If VBA.LenB(SecondWeek) = lCancelled_c Then Exit Sub
CompareWorksheets Worksheets(FirstWeek), Worksheets(SecondWeek)
End Sub
[/vba]

[Millertant]

Yep thats the business. Thanks very much for your help

[Oorang]

HTH