VBA - Compare Two Spreadsheets

[ajocius]

Group,
Can someone show me a compact comparison routine that will chec
cells one to one, only checking cells within the boundaries of the las
column with text in it and the last row with text in it. On
spreadsheet may have 2000 rows and the other usually has a few mor
rows added, appearing in appearing in the beginning, middle or end o
the spreadsheet. In some rows a single cell may change.
Everytime I try this problem, I get my self lost in mulitpl
For....Next statements and If....End If statements. Your assistanc
here can help a budding VBA programmer.

Thank you for your assistance.....

Ton

 

[Bernie Deitrick]

Tony,

I have written an add-in that will do a database style comparison - as long as your columns are in
the same order, it will highlight additions, deletions, and changes.

Contact me privately - reply to this message, and change my email address by taking out the spaces
and changing the dot to . - and I will send it to you.

HTH,
Bernie
MS Excel MVP

 

[keepITcool]

a simple (but fast!) off the cuff routine
for a 1 on 1 comparison is below.

advanced addin try www.synkronizer.com
which matches row/column structure values/formulas
and does highlighting etc. (free trial,paid license)

or try bernie's addin.


Option Explicit
Sub CompareRanges()
Dim rng(2) As Range
Dim cDif As Collection
Dim r&, c&, i%, n&
Dim val(1), itm, dmp

For i = 0 To 1
On Error Resume Next
Set rng(i) = _
Application.InputBox( _
"Select a range." & vbLf & _
"OneCell/AllCells translates to UsedRange", Type:=8)
If rng(i) Is Nothing Then
i = i - 1
ElseIf rng(i).Count = 1 Or rng(i).Count = 2 ^ 24 Then
Set rng(i) = rng(i).Worksheet.UsedRange
End If
Next
On Error GoTo 0
If rng(0).Worksheet Is rng(1).Worksheet Then
If Not Intersect(rng(0), rng(1)) Is Nothing Then
MsgBox "Ranges overlap"
Exit Sub
End If
End If

Set cDif = New Collection
val(0) = rng(0).Value
val(1) = rng(1).Value
For r = 1 To Application.Min( _
rng(0).Rows.Count, rng(1).Rows.Count)
For c = 1 To Application.Min( _
rng(0).Columns.Count, rng(1).Columns.Count)
If StrComp(val(0)(r, c), val(1)(r, c), vbTextCompare) <> 0 Then
cDif.Add Array(r, c)
End If

Next
If r Mod 1000 = 1 Then Application.StatusBar = "Comparing row: " & r
Next

If cDif.Count > Rows.Count Then
MsgBox "Too many differences!"
Exit Sub
End If

Application.StatusBar = "Preparing output"
ReDim dmp(1 To cDif.Count, 1 To 4)
For Each itm In cDif
n = n + 1
With rng(0)(itm(0), itm(1))
dmp(n, 1) = .Address
dmp(n, 2) = .Value
End With
With rng(1)(itm(0), itm(1))
dmp(n, 3) = .Address
dmp(n, 4) = .Value
End With

Next
Application.StatusBar = False

Set rng(2) = Application.InputBox(cDif.Count & _
"differences found" & vbLf & _
"Where to dump?", Type:=8)
rng(2).Resize(cDif.Count, 4) = dmp


End Sub





--
keepITcool
| www.XLsupport.com | keepITcool chello nl | amsterdam


ajocius wrote :

 

[Guest]

Bernie,

I would like a copy of your add-in if you don't mind. Would you reply so I
can reply? Thanks.

Tony,

I have written an add-in that will do a database style comparison - as long as your columns are in
the same order, it will highlight additions, deletions, and changes.

Contact me privately - reply to this message, and change my email address by taking out the spaces
and changing the dot to . - and I will send it to you.

HTH,
Bernie
MS Excel MVP

 

[Dnereb]

How about this:
Assuming you mean workbooks instead of spreadsheets programs


Code:
--------------------
Option Explicit

'Returns True if all cells in the workbook have the same text content (you could add formulas if you need to)

Function CompareWorkbooks(Wbook1 As Workbook, Wbook2 As Workbook) As Boolean

Dim Wsheet1 As Worksheet
Dim Wsheet2 As Worksheet
Dim I As Long, Col As Long, Rw As Long


'for clarity:
CompareWorkbooks = False

'first check the basics, before checking all cells

If Wbook1.Worksheets.Count <> Wbook2.Worksheets.Count Then Exit Function

For I = 1 To Wbook1.Worksheets.Count
If Wbook1.Worksheets(I).UsedRange.Columns.Count <> Wbook2.Worksheets(I).UsedRange.Columns.Count Then Exit Function
If Wbook1.Worksheets(I).UsedRange.Rows.Count <> Wbook2.Worksheets(I).UsedRange.Rows.Count Then Exit Function
Next

'check all cells
For I = 1 To Wbook1.Worksheets.Count
For Col = 1 To Wbook1.Worksheets(I).UsedRange.Columns.Count
For Rw = 1 To Wbook1.Worksheets(I).UsedRange.Rows.Count
'comment out the ones you do not need
If Wbook1.Worksheets(I).Cells(Rw, Col).Text <> Wbook2.Worksheets(I).Cells(Rw, Col).Text Then Exit Function
If Wbook1.Worksheets(I).Cells(Rw, Col).Value <> Wbook2.Worksheets(I).Cells(Rw, Col).Value Then Exit Function
If Wbook1.Worksheets(I).Cells(Rw, Col).Formula <> Wbook2.Worksheets(I).Cells(Rw, Col).Formula Then Exit Function

Next
Next
Next
CompareWorkbooks = True
End Function

Sub test()

Dim Wbook1 As Workbook
Dim Wbook2 As Workbook

Set Wbook1 = Application.Workbooks.Open("c:\test\test2.xls")
Set Wbook2 = Application.Workbooks.Open("c:\test\test3.xls")


If CompareWorkbooks(Wbook1, Wbook2) Then
MsgBox "the same!"
Else
MsgBox "different!"
End If

 

[nicksawe]

hi, could you please send me this addin? would greatly appreciate.

thanks