'

' 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