VBA to find matching results and highlight them.

[Shwapx]

Hello All,

I'm looking to create a VBA which can search for matching results between 2 columns, for example, columns A and B, and highlights the results in A with yellow color, but the tricky part is to consider the first result as nonmatch.

So let's say I will have this example:

So basically comparing two columns, but highlighting only the ones which match and their count is more than 1.

At the moment I have created a macro that can highlight cells in column A, but it doesn't make the comparison between B and it might highlight cells that are not relevant.

Thanks in advance!

 

[Akuini]

Try this:

Sub Shwapx()
Dim i As Long
Dim c As Range
Dim v As String
Dim va
Dim d As Object

Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary"): d.CompareMode = vbTextCompare

va = Range("B2", Cells(Rows.Count, "B").End(xlUp))

For i = 1 To UBound(va, 1)
    d(va(i, 1)) = Empty
Next

For Each c In Range("A2", Cells(Rows.Count, "A").End(xlUp))
    v = c.Value
    If d.Exists(v) Then
        If d(v) = Empty Then
            d(v) = 1
        Else
            c.Interior.Color = vbYellow
        End If
    End If
Next
Application.ScreenUpdating = True

End Sub

Book3
	A	B
1
2	G	H
3	A	A
4	H	G
5	G
6	N
7	H
8	G
9	M
10	H
Sheet1

 

[Shwapx]

Try this:

Sub Shwapx()
Dim i As Long
Dim c As Range
Dim v As String
Dim va
Dim d As Object

Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary"): d.CompareMode = vbTextCompare

va = Range("B2", Cells(Rows.Count, "B").End(xlUp))

For i = 1 To UBound(va, 1)
    d(va(i, 1)) = Empty
Next

For Each c In Range("A2", Cells(Rows.Count, "A").End(xlUp))
    v = c.Value
    If d.Exists(v) Then
        If d(v) = Empty Then
            d(v) = 1
        Else
            c.Interior.Color = vbYellow
        End If
    End If
Next
Application.ScreenUpdating = True

End Sub

Book3
	A	B
1
2	G	H
3	A	A
4	H	G
5	G
6	N
7	H
8	G
9	M
10	H
Sheet1

Hello It's working on the example sheet, but on my sheet the values are actually numbers like that (231-2341-1) and I'm getting type mismatch error on For i = 1 To UBound(va, 1)

 

[Shwapx]

I think it give me that result because i have only 1 value in COLUMN B

 

[Shwapx]

I think I fix that by extending the macro to get the header as well for value (which will never have a duplicate like the header) so it seems a good solution. Thank you so much for this it's amazing how quickly to build it!

 

[Akuini]

I think it give me that result because i have only 1 value in COLUMN B

Try this one:

Sub Shwapx2()
Dim i As Long
Dim c As Range
Dim v As String
Dim va, x
Dim d As Object

Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary"): d.CompareMode = vbTextCompare

va = Range("B2", Cells(Rows.Count, "B").End(xlUp))

If Not IsArray(va) Then va = Array(va)
For Each x In va
    d(x) = Empty
Next

For Each c In Range("A2", Cells(Rows.Count, "A").End(xlUp))
    v = c.Value
    If d.Exists(v) Then
        If d(v) = Empty Then
            d(v) = 1
        Else
            c.Interior.Color = vbYellow
        End If
    End If
Next
Application.ScreenUpdating = True

End Sub

 

[Shwapx]

Try this one:

Sub Shwapx2()
Dim i As Long
Dim c As Range
Dim v As String
Dim va, x
Dim d As Object

Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary"): d.CompareMode = vbTextCompare

va = Range("B2", Cells(Rows.Count, "B").End(xlUp))

If Not IsArray(va) Then va = Array(va)
For Each x In va
    d(x) = Empty
Next

For Each c In Range("A2", Cells(Rows.Count, "A").End(xlUp))
    v = c.Value
    If d.Exists(v) Then
        If d(v) = Empty Then
            d(v) = 1
        Else
            c.Interior.Color = vbYellow
        End If
    End If
Next
Application.ScreenUpdating = True

End Sub

Thanks it's working, what was causing that, it was working with adding the header with the previous code, but now works without header being considered.

 

[Akuini]

You're welcome.