Code:
Sub Compare()
Dim mainworkBook As Workbook
Set mainworkBook = ActiveWorkbook
For i = 4 To 11 Step 1
' NewPath = Cells(i, 6).Value
' OldPath = Cells(i, 7).Value
NewPath = mainworkBook.Sheets("Main").Cells(i, 6).Value
OldPath = mainworkBook.Sheets("Main").Cells(i, 7).Value
myExtension = "*.xls*"
MyNewFile = Dir(NewPath & myExtension)
' Sheets("Main").Range("AB1").Value = Dir(NewPath & myExtension)
MyOldFile = Dir(OldPath & myExtension)
Do While MyOldFile <> "" And MyNewFile <> ""
Set Newwb = Workbooks.Open(Filename:=NewPath & MyOldFile)
Newwb.Worksheets("Sheet1").Copy
Dim NewworkBook As Workbook
Set NewworkBook = ActiveWorkbook
Newwb.Close
Set Oldwb = Workbooks.Open(Filename:=OldPath & MyOldFile)
DoEvents
'Change First Worksheet's Background Fill Blue
' Newwb.Worksheets(1).Range("A1:Z1").Interior.Color = RGB(51, 98, 174)
' Oldwb.Worksheets(1).Range("A1:Z1").Interior.Color = RGB(51, 98, 174)
'Save and Close Workbook
' Newwb.Close SaveChanges:=True
' Oldwb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
Set ws1 = NewworkBook.Sheets("Sheet1")
Set ws2 = Oldwb.Sheets("Sheet1")
Dim ws1row As Long, ws2row As Long, ws1col As Integer, ws2col As Integer
Dim maxrow As Long, maxcol As Integer, colval1 As String, colval2 As String
'Dim New1 As Double, Old1 As Double
Dim report As Workbook, difference As Long
Dim row As Long, col As Long
Dim WrdArray() As String, Value As String
Set report = Workbooks.Add
With ws1.UsedRange
ws1row = .Rows.Count
ws1col = .Columns.Count
End With
With ws2.UsedRange
ws2row = .Rows.Count
ws2col = .Columns.Count
End With
maxrow = ws1row
maxcol = ws1col
If maxrow < ws2row Then maxrow = ws2row
If maxcol < ws2col Then maxcol = ws2cols
difference = 0
For col = 1 To maxcol
For row = 1 To maxrow
colval1 = ""
colval2 = ""
colval1 = CStr(Round(ws1.Cells(row, col).Value, 0)) 'new
colval2 = CStr(Round(ws2.Cells(row, col).Value, 0)) 'old
'New1 = colval1
'Old1 = colval2 * 1000
If colval2 <> "1" And Right(colval2, 1) = "%" Then
colval2 = Left(colval2, Len(colval2) - 1)
End If
If colval1 <> colval2 Then
If IsNumeric(colval1) = False And IsNumeric(colval2) = False And colval2 <> "0" Then
difference = difference + 1
Cells(row, col).Formula = (colval1 & "<> " & colval2)
Cells(row, col).Interior.Color = 255
Cells(row, col).Font.ColorIndex = 2
Cells(row, col).Font.Bold = True
End If
If (IsNumeric(colval1) = False And IsNumeric(colval2) = True) Or (IsNumeric(colval1) = True And IsNumeric(colval2) = False) And colval2 <> "0" Then
difference = difference + 1
Cells(row, col).Formula = (colval1 & "<> " & colval2)
Cells(row, col).Interior.Color = 255
Cells(row, col).Font.ColorIndex = 2
Cells(row, col).Font.Bold = True
End If
If IsNumeric(colval1) = True And IsNumeric(colval2) = True And colval2 <> "0" Then
If (colval1 - colval2 > 1) Then
difference = difference + 1
Cells(row, col).Formula = colval1 & "<> " & colval2
Cells(row, col).Interior.Color = 255
Cells(row, col).Font.ColorIndex = 2
Cells(row, col).Font.Bold = True
End If
End If
End If
Next row
Next col
Columns("A:B").ColumnWidth = 25
If difference = 0 Then
report.Close False
End If
If difference >= 1 Then
WrdArray() = Split(OldPath, "\")
Filename = Trim(MyOldFile)
report.SaveAs "C:\Users\VWW\Desktop\Shared\Results\Difference_" & WrdArray(6) & "_" & WrdArray(7) & "_" & Filename & ".xlsx"
report.Close True
Set report = Nothing
End If
Oldwb.Close
NewworkBook.Close SaveChanges:=False
' MsgBox difference & " cells contain different data! ", vbInformation, "Comparing Two Worksheets"
DoEvents
MyOldFile = Dir
Loop
Next
MsgBox "Task Complete!"
End Sub
Last edited by a moderator:
