Results 1 to 2 of 2

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

  1. #1
    Forum Guru Rick Rothstein's Avatar
    Join Date
    Feb 2012
    Posts
    659
    Rep Power
    13

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

    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
    Last edited by Rick Rothstein; 08-24-2015 at 10:48 PM.

  2. #2
    Junior Member
    Join Date
    Jul 2011
    Posts
    19
    Rep Power
    0
    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

Similar Threads

  1. Highlight Data Based on Data in Another Column
    By JohnYuhaschek in forum Excel Help
    Replies: 12
    Last Post: 01-29-2014, 10:00 PM
  2. Replies: 4
    Last Post: 06-01-2013, 01:08 PM
  3. Highlight Active Cell’s Row and Column
    By Transformer in forum Tips, Tricks & Downloads (No Questions)
    Replies: 0
    Last Post: 05-17-2013, 12:32 AM
  4. Replies: 6
    Last Post: 05-16-2013, 09:56 AM
  5. Replies: 35
    Last Post: 07-28-2012, 03:11 PM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •