A collection of fun web links
Highlights the difference between two IDENTICAL spreadsheets with DIFFERENT data values
Published on February 28, 2004 By webfun In Software Development


'
' Personal Macros by CD
'

Option Explicit

Public Sub HotAndCold()
'
' HotAndCold() by CD
'
Const xlColourHot As Integer = 38
Const xlColourCold As Integer = 34

Const MAXROWS As Integer = 200
Const MAXCOLS As Integer = 100

Dim wb As Workbook

Dim ws1 As Worksheet
Dim ws2 As Worksheet

Dim r1 As Range
Dim r2 As Range

Dim i As Integer
Dim j As Integer

' get wsheets
For Each wb In Application.Workbooks
If Not wb Is ThisWorkbook Then
If wb Is ActiveWorkbook Then
Set ws2 = wb.ActiveSheet
Else
Set ws1 = wb.ActiveSheet
End If
End If
If Not (ws1 Is Nothing) And Not (ws2 Is Nothing) Then Exit For
Next

If (ws1 Is Nothing) Or (ws2 Is Nothing) Then Exit Sub

MsgBox "Compare " & ws1.Parent.Name & "!" & ws1.Name & " with " &
ws2.Parent.Name & "!" & ws2.Name

Application.ScreenUpdating = False

For i = 1 To MAXROWS
Application.StatusBar = i
For j = 1 To MAXCOLS
Set r1 = ws1.Cells(i, j)
Set r2 = ws2.Cells(i, j)

If r1.Value < r2.Value Then
r2.Interior.ColorIndex = xlColourHot
UpdateComment r2, r1.Value
ElseIf r1.Value > r2.Value Then
r2.Interior.ColorIndex = xlColourCold
UpdateComment r2, r1.Value
Else
r2.Interior.ColorIndex = xlColorIndexNone
UpdateComment r2, vbNullString
End If
Next j
Next i

Application.ScreenUpdating = True

Application.StatusBar = False

End Sub

Private Sub UpdateComment(r As Range, cmt As String)
'
Dim c As Comment

Set c = r.Comment

' delete
If Not c Is Nothing Then
c.Delete
End If

If Len(cmt) Then
Set c = r.AddComment(cmt)
End If

Set c = Nothing

End Sub

Comments
No one has commented on this article. Be the first!