Compare two columns in two sheets and highlight values

[fahadun]

hello,
I am very new to vba programming. I am facing a new problem.
What i am trying to do here,
So i have two sheet, sheet1 and sheet2. Compare between sheet1 column "C" and sheet2 column "R".

• First highlight green,those mc# in sheet1 column "C", that are common in sheet1 and also in sheet2
• second highlight yellow, those mc# in sheet1 column "C", that mc# is in sheet1 but not in sheet2
• third highlight red, those mc# in sheet2 column "R", that mc# is not in sheet1 but is in sheet2

Next compare between sheet1 column "B" and sheet2 column "O".

• fourth highlight green,those wr# in sheet1 column "B", that are common in sheet1 and also in sheet2
• fifth highlight yellow, those wr# in sheet1 column "B", that wr# is in sheet1 but not in sheet2
• sixth highlight red, those wr# in sheet2 column "O", that wr# is not in sheet1 but is in sheet2

Thank you.

 

[MrKowz]

I'm sure this could be steamlined, but see if this accomplishes what you're needing:

Public Sub fahadun()
Dim d1          As Object, _
    d2          As Object
    
Dim ws1         As Worksheet, _
    ws2         As Worksheet
    
Dim LR1         As Long, _
    LR2         As Long
    
Dim i           As Long, _
    k           As Variant
    
Dim indexGreen  As Long, _
    indexYellow As Long, _
    indexRed    As Long
    
Dim rng         As Range, _
    rng1        As String
     
indexGreen = 4
indexYellow = 6
indexRed = 3
    
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")

'Compare columns C and R
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.dictionary")

LR1 = ws1.Range("C" & Rows.Count).End(xlUp).Row
LR2 = ws2.Range("R" & Rows.Count).End(xlUp).Row

For i = 2 To LR1
    If Not d1.Exists(ws1.Range("C" & i).Value) Then
        d1.Add ws1.Range("C" & i).Value, i
    End If
Next i

For i = 2 To LR2
    If Not d2.Exists(ws2.Range("R" & i).Value) Then
        d2.Add ws2.Range("R" & i).Value, i
    End If
Next i

For Each k In d1.Keys
    If d2.Exists(k) Then
        With ws1.Range("C:C")
            Set rng = .Find(k, LookIn:=xlValues, lookat:=xlWhole)
            If Not rng Is Nothing Then
                rng1 = rng.Address
                Do
                    rng.Interior.ColorIndex = indexGreen
                    Set rng = .FindNext(rng)
                Loop While Not rng Is Nothing And rng.Address <> rng1
            End If
        End With
    Else
        With ws1.Range("C:C")
            Set rng = .Find(k, LookIn:=xlValues, lookat:=xlWhole)
            If Not rng Is Nothing Then
                rng1 = rng.Address
                Do
                    rng.Interior.ColorIndex = indexYellow
                    Set rng = .FindNext(rng)
                Loop While Not rng Is Nothing And rng.Address <> rng1
            End If
        End With
    End If
Next k

For Each k In d2.Keys
    If Not d1.Exists(k) Then
        With ws2.Range("R:R")
            Set rng = .Find(k, LookIn:=xlValues, lookat:=xlWhole)
            If Not rng Is Nothing Then
                rng1 = rng.Address
                Do
                    rng.Interior.ColorIndex = indexRed
                    Set rng = .FindNext(rng)
                Loop While Not rng Is Nothing And rng.Address <> rng1
            End If
        End With
    End If
Next k

Set d1 = Nothing
Set d2 = Nothing

'Compare columns B and O
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.dictionary")

LR1 = ws1.Range("B" & Rows.Count).End(xlUp).Row
LR2 = ws2.Range("O" & Rows.Count).End(xlUp).Row

For i = 2 To LR1
    If Not d1.Exists(ws1.Range("B" & i).Value) Then
        d1.Add ws1.Range("B" & i).Value, i
    End If
Next i

For i = 2 To LR2
    If Not d2.Exists(ws2.Range("O" & i).Value) Then
        d2.Add ws2.Range("O" & i).Value, i
    End If
Next i

For Each k In d1.Keys
    If d2.Exists(k) Then
        With ws1.Range("B:B")
            Set rng = .Find(k, LookIn:=xlValues, lookat:=xlWhole)
            If Not rng Is Nothing Then
                rng1 = rng.Address
                Do
                    rng.Interior.ColorIndex = indexGreen
                    Set rng = .FindNext(rng)
                Loop While Not rng Is Nothing And rng.Address <> rng1
            End If
        End With
    Else
        With ws1.Range("B:B")
            Set rng = .Find(k, LookIn:=xlValues, lookat:=xlWhole)
            If Not rng Is Nothing Then
                rng1 = rng.Address
                Do
                    rng.Interior.ColorIndex = indexYellow
                    Set rng = .FindNext(rng)
                Loop While Not rng Is Nothing And rng.Address <> rng1
            End If
        End With
    End If
Next k

For Each k In d2.Keys
    If Not d1.Exists(k) Then
        With ws2.Range("O:O")
            Set rng = .Find(k, LookIn:=xlValues, lookat:=xlWhole)
            If Not rng Is Nothing Then
                rng1 = rng.Address
                Do
                    rng.Interior.ColorIndex = indexYellow
                    Set rng = .FindNext(rng)
                Loop While Not rng Is Nothing And rng.Address <> rng1
            End If
        End With
    End If
Next k

End Sub

 

[fahadun]

Still not working for the wr#. May be because The values in Sheet2!O:O are text-that-look-like-numbers while the values in Sheet1!B:B are true numbers. any solution for that? and is there any way to ignore empty cell in sheet2 columnR? because it's highlighting empty space too.