With the macro below it is possible to compare excel sheets.
The result is displayed in a new workbook listing all cell differences.
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 Worksheets.Count > 1
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
This example macro shows how to use the macro above:
Sub TestCompareWorksheets()
' compare two different worksheets in the active workbook
CompareWorksheets Worksheets("Sheet1"), Worksheets("Sheet2")
' compare two different worksheets in two different workbooks
CompareWorksheets ActiveWorkbook.Worksheets("Sheet1"), _
Workbooks("WorkBookName.xls").Worksheets("Sheet2")
End Sub
In this way we can compare 2 files.
The applications/code on this site are distributed as is and without warranties or liability. In no event shall the owner of the copyrights, or the authors of the applications/code be liable for any loss of profit, any problems or any damage resulting from the use or evaluation of the applications/code.
i want micro compare two workbooks with highlit same cell
Hi
I need help to write macro to compare two sheets in excel, sheet1 and sheet2 on same excel book and display all the differences between both the sheets on sheet3. My headings will always be the same between sheet1 and sheet2 but the information in both the sheets may vary. I included the headings that will be on both the sheets:
ID Number Date of Birth Payroll Number Surname First Name Salary Member Group
I am struggling with this. So please extend your helping hands Thank you.
i've a macro script to identify the matching column value in two open excel(Column A in first excel and column A in second excel) . I need matching column values to be copied to new excel(third excel) in column A. Please guide me.
Sub Compare()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim Cell As Range
Dim sBook As String
If Workbooks.Count < 2 Then
MsgBox "Error: Only one Workbook is open" & vbCr & _
"Open a 2nd Workbook and run this macro again."
Exit Sub
End If
Set wb1 = ThisWorkbook
For Each wb2 In Workbooks
If wb2.Name wb1.Name Then Exit For
Next
On Error Resume Next
ReDo1:
Application.DisplayAlerts = False
sBook = Application.InputBox(Prompt:= _
"Compare this workbook (" & wb1.Name & _
") to...?", _
Title:="Compare to what workbook?", _
Default:=wb2.Name, _
Type:=2)
If sBook = "False" Then Exit Sub
If Workbooks(sBook) Is Nothing Then
MsgBox "Workbook: " & sBook & " is not open."
GoTo ReDo1
Else
Set wb2 = Workbooks(sBook)
End If
Application.ScreenUpdating = False
For Each ws1 In wb1.Sheets
If Not wb2.Sheets(ws1.Name) Is Nothing Then
Set ws2 = wb2.Sheets(ws1.Name)
For Each Cell In ws1.UsedRange
If Cell.Formula = ws2.Range(Cell.Address).Formula Then
Cell.Interior.ColorIndex = 35
ws2.Range(Cell.Address). _
Interior.ColorIndex = 35
End If
Next Cell
If ws1.UsedRange.Rows.Count = _
ws2.UsedRange.Rows.Count Or _
ws1.UsedRange.Columns.Count = _
ws2.UsedRange.Columns.Count Then
For Each Cell In ws2.UsedRange
If Cell.Formula = ws1.Range(Cell.Address).Formula Then
Cell.Interior.ColorIndex = 35
ws1.Range(Cell.Address). _
Interior.ColorIndex = 35
End If
Next Cell
End If
End If
Next ws1
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I recieve an error:
Sub TestCompareWorksheets()
' compare two different worksheets in the active workbook
CompareWorksheets Worksheets("Sheet1"), Worksheets("Sheet2")
' compare two different worksheets in two different workbooks
CompareWorksheets ActiveWorkbook.Worksheets("Sheet1"), _
Workbooks("WorkBookName.xls").Worksheets("Sheet2")
------- CompareWorksheets ActiveWorkbook.Worksheets("Sheet1"), _
Workbooks("WorkBookName.xls").Worksheets("Sheet2") -> for me it tells 'subscript out of range (Error 9)' but when i delete it - sub works fine... so is it neccesary codeline?
I want to write a comparison macro between sheet 1 and sheet 2 where result will be displayed in sheet 3 in terms of True/False. Can anyone help me on this?
This macro working and being help a lot. Thank you for sharing it. Is there any way to inculde the column name in results sheet? It will be more informative if results sheet diplay the records which has differences along with Coulmn name?
I can get this code to work:
CompareWorksheets Worksheets("Sheet1"), Worksheets("Sheet2")
but when I try the alternate
' compare two different worksheets in two different workbooks
CompareWorksheets ActiveWorkbook.Worksheets("Sheet1"), _
Workbooks("WorkBookName.xls").Worksheets("Sheet2")
I get an error. My troubleshooting included:
Saving the workbook as an .xlsm file, renaming the sheets to compare, having the WB open, having it closed, moving the reference file to the same folder location as the active file, moving it to a different location as the active file. Maybe a couple other things too, I can't remember everything I tried.
The code I'm using is exactly what you have only I put in my file name and worksheet numbers:
CompareWorksheets ActiveWorkbook.Worksheets("24G"), _ Workbooks("S:\PD042\WORK\user name\P42-2 Bookplan-Tracking\P42-2 AMM Total Tracking Load Two.xlsm").Worksheets("24")
Does anything stand out to you as incorrect? or should this work as expected?
"You just have to copy the two example procedures above and paste them into a normal module sheet in your workbook (you can't use the sheet modules).
Open a workbook that contains two sheets you want to compare.
Edit the sheet names used in the macro ""TestCompareWorksheets"" (or, if you are lazy, rename the sheets in the workbook).
In Excel you press Alt+F8 to open the macro dialog box and run this macro: ""TestCompareWorksheets"".
A more detailed description of this procedure is available here:
http://www.erlandsendata.no/english/vba/howto.php "
very newbie at writting macros, so i can't make this one work... do i need any special add-in?
"You just have to copy the two example procedures above and paste them into a normal module sheet in your workbook (you can't use the sheet modules).
Open a workbook that contains two sheets you want to compare.
Edit the sheet names used in the macro ""TestCompareWorksheets"" (or, if you are lazy, rename the sheets in the workbook).
In Excel you press Alt+F8 to open the macro dialog box and run this macro: ""TestCompareWorksheets"".
A more detailed description of this procedure is available here:
I see error "Sub script out of range" while running
ub TestCompareWorksheets()
' compare two different worksheets in the active workbook
CompareWorksheets Worksheets("Sheet1"), Worksheets("Sheet2")
End Sub
Please help
very newbie at writting macros, so i can't make this one work... do i need any special add-in?