Highlight Words In One Column That Do Not Appear In A Second Column

**Rick Rothstein** · 08-24-2015, 10:46 PM

This has come up several times over the years, the usual request being to simply highlight the words or phrases in Column A that do not appear in Column B. The following code does this by highlighting those words in red. Both lists are assumed to start in Row 1 of their respective columns.

Code:

Sub HighlightWordsOneColumn()
  Dim X As Long, ColA As String
  Dim Words As Variant, vNum As Variant
  Words = Range("B1", Cells(Rows.Count, "B").End(xlUp))
  ColA = Chr(1) & Join(Application.Transpose(Range("A1", Cells(Rows.Count, "A").End(xlUp))), Chr(1) & Chr(1)) & Chr(1)
  For X = 1 To UBound(Words)
    ColA = Replace(ColA, Chr(1) & Words(X, 1) & Chr(1), Chr(1) & Chr(1))
  Next
  For Each vNum In Array(121, 13, 5, 3, 3, 2)
    ColA = Replace(ColA, String(vNum, Chr(1)), Chr(1))
  Next
  Words = Split(Mid(ColA, 2, Len(ColA) - 2), Chr(1))
  With Application
    .ScreenUpdating = False
    .ReplaceFormat.Clear
    .ReplaceFormat.Font.Color = vbRed
    For X = 0 To UBound(Words)
      Columns("A").Replace Words(X), Words(X), ReplaceFormat:=True
    Next
    .ReplaceFormat.Clear
    .ScreenUpdating = True
  End With
End Sub

The last request that I saw for this wanted to highlight both the words in Column A that were not listed in Column B and the words in Column B that were not listed in Column A. Here is the code I posted that does that.

Code:

Sub HighlightWordsTwoColumns()
  Dim X As Long, ColA As String, ColB As String
  Dim Awords As Variant, Bwords As Variant, vNum As Variant
  Awords = Range("A1", Cells(Rows.Count, "A").End(xlUp))
  Bwords = Range("B1", Cells(Rows.Count, "B").End(xlUp))
  ColA = Chr(1) & Join(Application.Transpose(Awords), Chr(1) & Chr(1)) & Chr(1)
  ColB = Chr(1) & Join(Application.Transpose(Bwords), Chr(1) & Chr(1)) & Chr(1)
  For X = 1 To UBound(Awords)
    ColB = Replace(ColB, Chr(1) & Awords(X, 1) & Chr(1), Chr(1) & Chr(1))
  Next
  For X = 1 To UBound(Bwords)
    ColA = Replace(ColA, Chr(1) & Bwords(X, 1) & Chr(1), Chr(1) & Chr(1))
  Next
  For Each vNum In Array(121, 13, 5, 3, 3, 2)
    ColA = Replace(ColA, String(vNum, Chr(1)), Chr(1))
    ColB = Replace(ColB, String(vNum, Chr(1)), Chr(1))
  Next
  Awords = Split(Mid(ColA, 2, Len(ColA) - 2), Chr(1))
  Bwords = Split(Mid(ColB, 2, Len(ColB) - 2), Chr(1))
  With Application
    .ScreenUpdating = False
    .ReplaceFormat.Clear
    .ReplaceFormat.Font.Color = vbRed
    For X = 0 To UBound(Awords)
      Columns("A").Replace Awords(X), Awords(X), ReplaceFormat:=True
    Next
    For X = 0 To UBound(Bwords)
      Columns("B").Replace Bwords(X), Bwords(X), ReplaceFormat:=True
    Next
    .ReplaceFormat.Clear
    .ScreenUpdating = True
  End With
End Sub

**jomili** · 01-28-2016, 07:37 PM

When I do this column comparison I want a permanent record without interfering with my source data, so put it on another sheet. Also, I don't always want to compare A and B, sometimes it's J and Q or R and X. The macro below does all of that. I'm sure it could be cleaned up, but it's working as is. BTW, "Speedon" and "Speedoff" are twin macros I have to turn off or on screenupdating, calculations, etc.

Code:

Sub CompareColumns()
'Excel macro to compare two columns.
'Copies the two columns to a new sheet, into A and B
'Populates column C with unique values in A and not in B
'Populates column D with unique values in B and not in A
'Puts the values found in both A and B in column E.

'This little section of code tells the addresses of each unigue column picked.
    Dim rCol1 As Range, rCol2 As Range
    If Intersect(Selection, Selection.Cells(1).EntireRow).Count = 2 Then
        If Selection.Areas.Count > 1 Then
            Set rCol1 = Selection.Areas(1)
            Set rCol2 = Selection.Areas(2)
        Else
            Set rCol1 = Selection.Columns(1)
            Set rCol2 = Selection.Columns(2)
        End If
    Else
        MsgBox "This macro requires two and only two columns for comparison.", vbOKOnly + vbCritical, "Wrong Number of Columns Selected"
        Exit Sub
    End If

SpeedOn
Dim ws As Worksheet

On Error GoTo LetsQuit
For Each ws In Worksheets
    If ws.Name = "Comparison" Then
        Application.DisplayAlerts = False
        ws.Name = "old_Comparison"
        Application.DisplayAlerts = True
    End If
Next
On Error Resume Next

Worksheets.Add().Name = "Comparison"
 rCol1.Copy Destination:=ActiveSheet.Range("A1")
 rCol2.Copy Destination:=ActiveSheet.Range("B1")
 
    Rows(1).Insert
    Range("A1:E1").Value = Array("Col " & rCol1.Address, "Col " & rCol2.Address, _
                "In " & rCol1.Address & ", not in " & rCol2.Address, _
                "In " & rCol2.Address & ", not in " & rCol1.Address, "In both Columns")
    Dim d As Object, na&, nb&, a, b
    Dim e, p&, q&, r&, m
    Set d = CreateObject("scripting.dictionary")

    na = Range("A" & Rows.Count).End(3).row
    a = Range("A2:A" & na)
    nb = Range("B" & Rows.Count).End(3).row
    b = Range("B2:B" & nb)
    ReDim c(1 To Application.Max(na, nb), 1 To 3)
    For Each e In a: d(e) = 1: Next
    For Each e In b
        If d(e) = 1 Then
            r = r + 1
            c(r, 3) = e
        Else
            q = q + 1
            c(q, 2) = e
        End If
    Next
    d.RemoveAll
    For Each e In b: d(e) = 1: Next
    For Each e In a
        If d(e) <> 1 Then
            p = p + 1
            c(p, 1) = e
        End If
    Next
    m = Application.Max(p, q, r)
    Range("C2").Resize(m, 3) = c
    
     With Columns("A:E")
        .Font.Name = "Arial"
        .EntireColumn.AutoFit
    End With

    With Rows("1:1")
        With .Font
            .Bold = True
            .Name = "Calibri"
            .Color = -16776961
            .TintAndShade = 0
        End With
        .HorizontalAlignment = xlCenter
    End With
    Rows("2:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    SpeedOff
Exit Sub

LetsQuit:
SpeedOff
MsgBox "Please delete or rename the old_Comparison sheet"
Exit Sub
End Sub