This macro is a modified version of a similar solution I provided (se
below for link) that should work for you:
Code
-------------------
Sub compareSheets()
' Declare variables/data types...
Dim origFile, origSheet, copySheet As Worksheet
Dim origRange, copyRange, compRange, errLoc As String
Dim x, y, compCount, errCount, iRow As Long
Dim origRows, minOrigR, minOrigC, minCopyR, minCopyC As Long
Dim copyRows, rowLim, colLim, rowMin, colMin, compMin, compLim As Long
Dim origCols, copyCols As Integer
Dim origVal, copyVal As Variant
Dim Msg, Title As String, Style, Response As Variant
Dim errArray() As Variant
' Set 'original' workbook variable...
Set origFile = ActiveWorkbook
' Compare sheet 1 vs. sheet 2...
Set origSheet = origFile.Sheets(1)
Set copySheet = origFile.Sheets(2)
' Get 'original' data range (in "A1" format)...
origRange = origSheet.UsedRange.Address(RowAbsolute:=False, ColumnAbsolute:=False)
' Get 'copy' data range (in "A1" format)...
copyRange = copySheet.UsedRange.Address(RowAbsolute:=False, ColumnAbsolute:=False)
' Get 'original' & 'copy' data range limits to process...
origRows = origSheet.UsedRange.Rows.Count
origCols = origSheet.UsedRange.Columns.Count
minOrigR = origSheet.UsedRange.Cells(1, 1).Row
minOrigC = origSheet.UsedRange.Cells(1, 1).Column
copyRows = copySheet.UsedRange.Rows.Count
copyCols = copySheet.UsedRange.Columns.Count
minCopyR = copySheet.UsedRange.Cells(1, 1).Row
minCopyC = copySheet.UsedRange.Cells(1, 1).Column
' Determine data range 'size' and adjust range to ensure comparison
' will be accurate (use the greatest row & column count)...
rowLim = Application.WorksheetFunction.Max(origRows, copyRows)
colLim = Application.WorksheetFunction.Max(origCols, copyCols)
rowMin = Application.WorksheetFunction.Min(minOrigR, minCopyR)
colMin = Application.WorksheetFunction.Min(minOrigC, minCopyC)
compMin = Application.WorksheetFunction.Min(rowMin, colMin)
compLim = Application.WorksheetFunction.Max(RowMax, ColMax)
compRange = origSheet.Range(origSheet.Cells(rowMin, colMin), _
origSheet.Cells(rowLim, colLim)).Address(RowAbsolute:=False, ColumnAbsolute:=False)
' Initialize mismatch counter...
errCount = 0
' Initialize comparison counter...
compCount = 0
' Loop through each cell in 'resized' data range by row index...
For x = 1 To rowLim
' Loop through each cell in 'resized' data range by column index...
For y = 1 To colLim
' Start comparison counter...
compCount = compCount + 1
' Perform comparison & load array if compared cells differ...
If origSheet.Cells(x, y).Value <> copySheet.Cells(x, y).Value Then
' Increment mismatch counter...
errCount = errCount + 1
' If 'original' value is blank, assign it to variable...
If origSheet.Cells(x, y).Value = "" Then
origVal = "<blank>"
Else
' Otherwise, use 'original' value...
origVal = origSheet.Cells(x, y).Value
End If
' If 'copy' cell is blank, assign it to variable...
If copySheet.Cells(x, y).Value = "" Then
copyVal = "<blank>"
Else
' Otherwise, use 'copy' value...
copyVal = copySheet.Cells(x, y).Value
End If
' Redimension array that stores mismatches (add 1st row)
If errCount = 1 Then
ReDim errArray(1)
Else
' Retain existing array data and add new row to array...
ReDim Preserve errArray(UBound(errArray) + 1)
End If
' Add mismatch info (using variable) to array by subtracting 1
' from mismatch count to equal row index of array (Option Base 0)
errArray(UBound(errArray) - 1) = origVal
End If
' Loop to next column in 'resized' data range...
Next y
' Loop to next row in 'resized' data range...
Next x
' If differences exist, create new sheet and list them...
If errCount > 0 Then
ThisWorkbook.Worksheets.Add After:=ThisWorkbook.Worksheets(2)
For iRow = 0 To UBound(errArray)
ActiveSheet.Cells(iRow + 1, 1).Value = errArray(iRow)
Next iRow
Else
' Otherwise, alert user no differences were found...
Msg = "No differences were found in the comparison."
Style = vbOKOnly + vbInformation + vbDefaultButton1
Title = "File Comparison Results"
Response = MsgBox(Msg, Style, Title)
End If
End Sub
--------------------
For the original solution, here’s the link:
http://www.excelforum.com/showthread.php?p=955417#post955417
Hope this helps,
theDude
