Could any one help me with a code to compare two excel sheets and return the differences to a new sheet with the corresponding headers in VBA.??
need to modify this code to get the header section included while the mismatching values are returned.!!
Sub Compare_Two_Excel_Sheets_Highlight_Differences()
'Define Fields
Dim OutputLastRow As Long
Dim iRow As Double, iCol As Double, oRow As Double
Dim iRow_Max As Double, iCol_Max As Double
Dim sh1 As Worksheet, sh2 As Worksheet
Dim shOut As Worksheet
'Sheets to be compared
Set sh1 = ThisWorkbook.Sheets(1)
Set sh2 = ThisWorkbook.Sheets(2)
Set shOut = ThisWorkbook.Sheets(3)
'Max Rows
iRow_Max = sh1.UsedRange.Rows.Count
iCol_Max = sh1.UsedRange.Columns.Count
'Read Data From Each Sheets of Both Excel Files & Compare Data
For iRow = 1 To iRow_Max
For iCol = 1 To iCol_Max
sh1.Cells(iRow, iCol).Interior.Color = xlNone
sh2.Cells(iRow, iCol).Interior.Color = xlNone
'Compare Data From Excel Sheets & Highlight the Mismatches
If sh1.Cells(iRow, iCol) <> sh2.Cells(iRow, iCol) Then
sh1.Cells(iRow, iCol).Interior.Color = vbYellow
sh2.Cells(iRow, iCol).Interior.Color = vbYellow
'Write Differences to Output sheet
oRow = oRow + 1
shOut.Cells(oRow, 1) = sh1.Cells(iRow, iCol)
shOut.Cells(oRow, 2) = sh2.Cells(iRow, iCol)
End If
Next iCol
Next iRow
'Process Completed
MsgBox "Task Completed"
End Sub
Related
I am working on a Project which requires me to compare two excel sheets and need to highlight the differences and also return the unique values.I was able to get it to be work till here but i would need help in copying these returned values in a different sheet but under the same headers meaning the values returned must have their corresponding headers under them. I have written the code till here need further assistance.
Option Explicit
Sub Compare_Two_Excel_Sheets_Highlight_Differences()
'Define Fields
Dim iRow As Double, iCol As Double, oRow As Double
Dim iRow_Max As Double, iCol_Max As Double
Dim sh1 As Worksheet, sh2 As Worksheet
Dim shOut As Worksheet
'Sheets to be compared
Set sh1 = ThisWorkbook.Sheets(1)
Set sh2 = ThisWorkbook.Sheets(2)
Set shOut = ThisWorkbook.Sheets(3)
'Max Rows
iRow_Max = sh1.UsedRange.Rows.Count
iCol_Max = sh1.UsedRange.Columns.Count
'Read Data From Each Sheets of Both Excel Files & Compare Data
For iRow = 1 To iRow_Max
For iCol = 1 To iCol_Max
sh1.Cells(iRow, iCol).Interior.Color = xlNone
sh2.Cells(iRow, iCol).Interior.Color = xlNone
'Compare Data From Excel Sheets & Highlight the Mismatches
If sh1.Cells(iRow, iCol) <> sh2.Cells(iRow, iCol) Then
sh1.Cells(iRow, iCol).Interior.Color = vbYellow
sh2.Cells(iRow, iCol).Interior.Color = vbYellow
'Write Differences to Output sheet
oRow = oRow + 1
shOut.Cells(oRow, 1) = sh1.Cells(iRow, iCol)
shOut.Cells(oRow, 2) = sh2.Cells(iRow, iCol)
End If
Next iCol
Next iRow
'Process Completed
MsgBox "Task Completed"
End Sub
I am trying to compare each cell on one sheet to each cell on another sheet and then highlight the differences. For example, I want to see if cell a2 on one sheet is the same as cell a2 on another sheet. At one point, I was able to run a comparison, but it was just looking for a match within the whole sheet, not just specific cells, so I was getting false positives. I am obviously missing the piece that makes the cell to cell comparison. New to VBA so here is what I have cobbled together so far:
Option Explicit
Sub test()
Dim varSheetA As Variant
Dim varSheetB As Variant
Dim strRangeToCheck As String
Dim iRow As Long
Dim iCol As Long
Dim cell As Variant
strRangeToCheck = "A1:Z5000"
Debug.Print Now
varSheetA = Worksheets("RoboReader").Range(strRangeToCheck)
varSheetB = Worksheets("Uploader").Range(strRangeToCheck)
Debug.Print Now
For iRow = LBound(varSheetA, 1) To UBound(varSheetA, 1)
For iCol = LBound(varSheetA, 2) To UBound(varSheetA, 2)
If varSheetA(iRow, iCol) = varSheetB(iRow, iCol) Then
' Cells are identical.
' Do nothing.
Else
Cells.Font.Bold = True
Cells.Font.ColorIndex = 2
Cells.Interior.ColorIndex = 8
Cells.Interior.Pattern = xlSolid
End If
Next iCol
Next iRow
End Sub
Cell by Cell Comparison
When using Cells without a qualifier, it means all (1048576*16384)
cells on the Activesheet.
When you use the equal sign (=) in an If statement, the opposite
is (<>). You can eliminate the equal part since nothing will be
happening then.
A Quick Fix
Option Explicit
Sub test()
Dim varSheetA As Variant
Dim varSheetB As Variant
Dim strRangeToCheck As String
Dim iRow As Long
Dim iCol As Long
Dim cell As Variant
'Worksheets("Uploader").Cells.ClearFormats
strRangeToCheck = "A1:Z5000"
Debug.Print Now
varSheetA = Worksheets("RoboReader").Range(strRangeToCheck)
varSheetB = Worksheets("Uploader").Range(strRangeToCheck)
Debug.Print Now
For iRow = LBound(varSheetA, 1) To UBound(varSheetA, 1)
For iCol = LBound(varSheetA, 2) To UBound(varSheetA, 2)
If varSheetA(iRow, iCol) <> varSheetB(iRow, iCol) Then
With Worksheets("Uploader").Cells(iRow, iCol)
.Font.Bold = True
.Font.ColorIndex = 2
.Interior.ColorIndex = 8
.Interior.Pattern = xlSolid
End With
End If
Next iCol
Next iRow
End Sub
I am trying to write a script that will compare two workbooks that each have 80 sheets. The sheet names will match in both workbooks (one workbook is a prod copy, one is a copy from a UAT environment. All data should be same). I was able to run a script that will compare the sheet I specify, but I'm having difficulty trying to figure out how to write it to compare each sheet.
Sub CompareWorksheets()
Dim varSheetA As Worksheet
Dim varSheetB As Worksheet
Dim varSheetAr As Variant
Dim varSheetBr As Variant
Dim strRangeToCheck As String
Dim iRow As Long
Dim iCol As Long
Dim wbkc As Workbook
Set wbkc = ThisWorkbook 'this is where results of comparison will be documented
Set wbka = Workbooks.Open(Filename:="C:\Users\Desktop\dashboard1.xlsx") 'PROD
Set wbkb = Workbooks.Open(Filename:="C:\Users\Desktop\dashboard2.xlsx") 'UAT
Set varSheetA = wbka.Worksheets("Members")
Set varSheetB = wbkb.Worksheets("Members")
strRangeToCheck = ("A5:A10")
varSheetAr = varSheetA.Range(strRangeToCheck).Value
varSheetBr = varSheetB.Range(strRangeToCheck).Value
erow = 6 'starting row to document summary results
For iRow = LBound(varSheetAr, 1) To UBound(varSheetAr, 1)
For iCol = LBound(varSheetAr, 2) To UBound(varSheetAr, 2)
If varSheetAr(iRow, iCol) = varSheetBr(iRow, iCol) Then
varSheetA.Cells(iRow, iCol).Interior.ColorIndex = xlNone
varSheetB.Cells(iRow, iCol).Interior.ColorIndex = xlNone
Else
varSheetA.Cells(iRow, iCol).Interior.ColorIndex = 22
varSheetB.Cells(iRow, iCol).Interior.ColorIndex = 22
wbkc.Activate
erow = erow + 1
wbkc.Sheets("Summary").Cells(erow, 2) = iRow
wbkc.Sheets("Summary").Cells(erow, 3) = iCol
wbkc.Sheets("Summary").Cells(erow, 4) = varSheetA.Cells(iRow, iCol)
wbkc.Sheets("Summary").Cells(erow, 5) = varSheetB.Cells(iRow, iCol)
End If
Next
Next
End Sub
You need to iterate through the Worksheets of one of the workbooks and use the worksheet names to set worksheet variable for the second workbook.
Sub CompareWorksheets()
Dim wbPROD As Workbook, wbUAT As Workbook, wbSummary As Workbook
Dim wsPROD As Worksheet, wsUAT As Worksheet, wsSummary As Worksheet
Dim arrPROD As Variant, arrUAT As Variant
Dim strRangeToCheck As String
Dim iRow As Long, iCol As Long
Set wbSummary = ThisWorkbook 'this is where results of comparison will be documented
Set wsSummary = wbkc.Sheets("Summary")
Set wbPROD = Workbooks.Open(Filename:="C:\Users\Desktop\dashboard1.xlsx") 'PROD
Set wbUAT = Workbooks.Open(Filename:="C:\Users\Desktop\dashboard2.xlsx") 'UAT
strRangeToCheck = ("A5:A10")
erow = 6 'starting row to document summary results
For Each wsPROD In wbPROD.Worksheets
Set wsUAT = wbUAT.Worksheets(wsPROD.Name)
arrPROD = wsPROD.Range(strRangeToCheck).Value
arrUAT = wsUAT.Range(strRangeToCheck).Value
For iRow = LBound(arrPROD, 1) To UBound(arrPROD, 1)
For iCol = LBound(arrPROD, 2) To UBound(arrPROD, 2)
If arrPROD(iRow, iCol) = arrUAT(iRow, iCol) Then
wsPROD.Cells(iRow, iCol).Interior.ColorIndex = xlNone
wsUAT.Cells(iRow, iCol).Interior.ColorIndex = xlNone
Else
wsPROD.Cells(iRow, iCol).Interior.ColorIndex = 22
wsUAT.Cells(iRow, iCol).Interior.ColorIndex = 22
wbkc.Activate
erow = erow + 1
With wsSummary
.Cells(erow, 2) = iRow
.Cells(erow, 3) = iCol
.Cells(erow, 4) = wsPROD.Cells(iRow, iCol)
.Cells(erow, 5) = wsUAT.Cells(iRow, iCol)
End With
End If
Next
Next
Next
End Sub
Start with
Option Explicit ' to force you to declare for each variable
Add code to delete prior errors
Dim wbkc As Workbook, LastRow as Long, nRow as Long
wbkc.Sheets("Summary").UsedRange 'Refresh UsedRange
LastRow = wbkc.Sheets("Summary").UsedRange.Rows(wbkc.Sheets("Summary").UsedRange.Rows.Count).Row
For nRow = LastRow to eRow + 1 step -1
wbkc.Sheets("Summary").Rows(nRow).Delete
Next nRow
Basically, google "excel vba for each sheet" and look at the first one
https://stackoverflow.com/questions/21918166/excel-vba-for-each-worksheet-loop
to get the driving code (ignoring resizingColumns) and create CompareCells.
Sub forEachWs()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
Call CompareCells(ws)
Next
End Sub
Sub CompareCells(ws as Worksheet)
End Sub
Finally, Add your code inside of CompareCells
Giving (PLEASE test this code, since we do not have wbka or wbkb excel files)
Option Explicit ' to force you to declare for each variable
' define output -- this is where results of comparison will be documented
Dim wbkc As Workbook, eRow as long, LastRow as Long, nRow as Long
Set wbkc = ThisWorkbook
eRow = 6 'starting row to document summary results
wbkc.Sheets("Summary").UsedRange 'Refresh UsedRange
LastRow = wbkc.Sheets("Summary").UsedRange.Rows(wbkc.Sheets("Summary").UsedRange.Rows.Count).Row
For nRow = LastRow to eRow + 1 step -1
wbkc.Sheets("Summary").Rows(nRow).Delete ' delete prior errors
Next nRow
' define inputs --
Dim wbka As Workbook, wbkb As Workbook
Set wbka = Workbooks.Open(Filename:="C:\Users\Desktop\dashboard1.xlsx") 'PROD
Set wbkb = Workbooks.Open(Filename:="C:\Users\Desktop\dashboard2.xlsx") 'UAT
' step thru each sheet
Dim ws As Worksheet
For Each ws In wbka.Worksheets
'
Dim varSheetA As Worksheet, varSheetB As Worksheet
Dim varSheetAr As Variant, varSheetBr As Variant
Dim strRangeToCheck As String
Set varSheetA = wbka.Worksheets(ws.Name)
Set varSheetB = wbkb.Worksheets(ws.Name)
strRangeToCheck = ("A5:A10")
varSheetAr = varSheetA.Range(strRangeToCheck).Value
varSheetBr = varSheetB.Range(strRangeToCheck).Value
' step thru each cell
Dim iRow As Long, iCol As Long
For iRow = LBound(varSheetAr, 1) To UBound(varSheetAr, 1)
For iCol = LBound(varSheetAr, 2) To UBound(varSheetAr, 2)
If varSheetAr(iRow, iCol) = varSheetBr(iRow, iCol) Then
varSheetA.Cells(iRow, iCol).Interior.ColorIndex = xlNone
varSheetB.Cells(iRow, iCol).Interior.ColorIndex = xlNone
Else
varSheetA.Cells(iRow, iCol).Interior.ColorIndex = 22
varSheetB.Cells(iRow, iCol).Interior.ColorIndex = 22
wbkc.Activate
erow = erow + 1
wbkc.Sheets("Summary").Cells(erow, 1) = ws.Name 'ADDed
wbkc.Sheets("Summary").Cells(erow, 2) = iRow
wbkc.Sheets("Summary").Cells(erow, 3) = iCol
wbkc.Sheets("Summary").Cells(erow, 4) = varSheetA.Cells(iRow, iCol)
wbkc.Sheets("Summary").Cells(erow, 5) = varSheetB.Cells(iRow, iCol)
End If
Next iCol
Next iRow
Next ws
I'm trying to compare cells in 2 tabs (master and test) and if there are changes in test then color changes in any kind of color and copy & paste it to master file.
UPDATED:
Here is required code
Sub test()
Dim varSheetA As Variant
Dim varSheetB As Variant
Dim strRangeToCheck As String
Dim iRow As Long
Dim iCol As Long
Dim jRow As Long
Dim jCol As Long
strRangeToCheck = "A1:V1000"
' If you know the data will only be in a smaller range, reduce the size of the ranges above.
Debug.Print Now
varSheetA = Worksheets("Sheet1").Range(strRangeToCheck)
varSheetB = Worksheets("Sheet2").Range(strRangeToCheck) ' or whatever your other sheet is.
Debug.Print Now
For iRow = LBound(varSheetA, 1) To UBound(varSheetA, 1)
For iCol = LBound(varSheetA, 2) To UBound(varSheetA, 2)
If varSheetB(iRow, iCol) = varSheetA(iRow, iCol) Then
' Cells are identical.
' Do nothing.
Else
Sheets("Sheet1").Select
Cells(iRow, iCol).Interior.ColorIndex = 44
Sheets("Sheet2").Select
Cells(iRow, iCol).Interior.ColorIndex = 44
Sheets("Sheet2").Select
Cells(iRow, iCol).Copy
Sheets("Sheet1").Select
Cells(iRow, iCol).PasteSpecial xlValues
Cells(iRow, iCol).PasteSpecial xlFormats
' Cells are different.
' Code goes here for whatever it is you want to do.
End If
Next iCol
Next iRow
MsgBox ("Done")
End Sub
Find the last used cell in one of the worksheets.
dim lr as long, lc as long
lr= application.max(dWS.cells.specialcells(xlCellTypeLastCell).row, _
mWS.cells.specialcells(xlCellTypeLastCell).row)
lc= application.max(dWS.cells.specialcells(xlCellTypeLastCell).Column, _
mWS.cells.specialcells(xlCellTypeLastCell).Column)
For Each c In dWS.Range("A2", dWS.cells(lr, lc))
If Not dWS.Cells(c.Row, c.Column).Value = mWS.Cells(c.Row, c.Column).Value Then
dWS.Cells(c.Row, c.Column).Interior.Color = vbYellow
End If
Next
UPDATE:
Situation: I have data that I am trying to consolidate by summing rows based on the first column value (item ID number). If the ID numbers match I want the rows to be added together and the duplicate rows deleted.
I have written the following code and I am experiencing 2 issues:
1. The first time I run the code there is always a few duplicates left that were not consolidated
2. If I run the code again it sums and deletes rows even if they are not duplicates.
Any help would be much appreciated.
Sub ConsolidateRows()
Dim WB As Workbook
Dim WS As Worksheet
Dim iRow As Long
Dim iCol As Long
Dim LastRow As Long
Dim LastCol As Long
Dim duplicate As String
Dim dupRow As Long
Dim cell As Range
Dim i As Integer
'set
Set WB = Workbooks("Book1")
Set WS = WB.Sheets("Data")
LastRow = WS.UsedRange.Rows.Count
LastCol = WS.UsedRange.Columns.Count
'Loop to consolidate, delete the duplicate rows
iRow = 1
While WS.Cells(iRow, 1).Value <> ""
duplicate = Cells(iRow, 1).Value
iRow = iRow + 1
For Each cell In WS.Range("A1:A" & LastRow).Cells
dupRow = cell.Row
If cell.Value = duplicate And iRow <> dupRow Then
For iCol = 3 To LastCol
Cells(iRow, iCol) = Application.WorksheetFunction.Sum(Cells(iRow, iCol), Cells(dupRow, iCol))
Next iCol
WS.Rows(dupRow).Delete
End If
Next cell
Wend
End Sub
You shouldn't delete rows this way, as the range you are looping will start changing and not refer to the desired cells. The quickest fix (without totally restructuring the logic) is to add a variable that holds the rows you want to delete, then delete them all after. My favorite method is using a string with commas as delimiters (easier than using an array)
Dim rowsToDelete As String
For Each cell In WS.Range("A2:A" & LastRow).Cells
jRow = cell.Row
If cell.Value = "Desired Value" Then
'Do Something
rowsToDelete = rowsToDelete & jRow & ","
End If
Next cell
If Len(rowstoDelete) > 1 Then rowstoDelete = Left(rowsToDelete,Len(rowstoDelete) - 1)
If Len(rowstoDelete) > 0 then
For i = UBound(Split(rowstoDelete,",")) to 0 Step -1
WS.Rows(Split(rowstoDelete,",")(i)).Delete
Next i
End If