Comparing data from one column with data within another column

[Guest]

Hi,

am hoping someone out there can help me! I have one column of names, and I
want to identify within the next column everytime one of those names appears.
I can't just compare the columns though, because the names are embedded in
the second column.

i.e. Column A Column B
John Brown [Juliette Smith/Peter Smith/Brenda Jones]
Peter Smith [Adam Beechway/Trent Bandaly]
Carole Jones [Saby Sun\John Brown]

In this example, I want the John Brown and Peter Smith in Column B to be
highlighted. My list contains about 1500 rows, though Column B is slightly
shorter than Column A. Also, Column B does contain some blank cells.

Any help would be much appreciated!

Thanks
Emily

 

[Ken Johnson]

Hi Emily,

Try this macro out on a copy of your worksheet. It worked on the
example data you supplied.

It converts found names to bold.

Public Sub HighlightNames()
Application.ScreenUpdating = False
Dim lnLAtRowA As Long
Dim lnLastRowB As Long
Dim I As Long
Dim J As Long
lnlastrowA = _
ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
lnLastRowB = _
ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
For I = 1 To lnlastrowA
If Cells(I, 1) = "" Then GoTo BLANKA
For J = 1 To lnLastRowB
If Cells(J, 2) = "" Then GoTo BLANKB
On Error Resume Next
If Not (WorksheetFunction.IsError _
(WorksheetFunction.Find _
(Cells(I, 1).Value, Cells(J, 2)))) Then
Cells(J, 2).Characters _
(WorksheetFunction.Find _
(Cells(I, 1).Value, Cells(J, 2)), _
Len(Cells(I, 1).Value)).Font.Bold = True
End If
BLANKB: Next J
BLANKA: Next I
End Sub

Ken Johnson

 

[Ken Johnson]

Oops.

Last one had typo error (still worked though)

SHOULD HAVE BEEN...

Public Sub HighlightNames()
Application.ScreenUpdating = False
Dim lnLastRowA As Long
Dim lnLastRowB As Long
Dim I As Long
Dim J As Long
lnLastRowA = _
ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
lnLastRowB = _
ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
For I = 1 To lnLastRowA
If Cells(I, 1) = "" Then GoTo BLANKA
For J = 1 To lnLastRowB
If Cells(J, 2) = "" Then GoTo BLANKB
On Error Resume Next
If Not (WorksheetFunction.IsError _
(WorksheetFunction.Find _
(Cells(I, 1).Value, Cells(J, 2)))) Then
Cells(J, 2).Characters _
(WorksheetFunction.Find _
(Cells(I, 1).Value, Cells(J, 2)), _
Len(Cells(I, 1).Value)).Font.Bold = True
End If
BLANKB: Next J
BLANKA: Next I
End Sub

Ken Johnson

 

[Dave Peterson]

Just a note.

Instead of using worksheetfunction.find(), you could use VBA's own inStr().
Then you could check to see if that's = 0 (instead of using
worksheetfunction.iserror()).

 

[Ken Johnson]

Using Dave's suggestion for improvement...

Public Sub HighlightNames()
Application.ScreenUpdating = False
Dim lnLastRowA As Long
Dim lnLastRowB As Long
Dim I As Long
Dim J As Long
Dim lnStartChar As Long
lnLastRowA = _
ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
lnLastRowB = _
ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
For I = 1 To lnLastRowA
If Cells(I, 1) = "" Then GoTo BLANKA
For J = 1 To lnLastRowB
If Cells(J, 2) = "" Then GoTo BLANKB
lnStartChar = InStr(Cells(J, 2).Value, Cells(I,
1).Value)
If lnStartChar <> 0 Then
Cells(J, 2).Characters _
(lnStartChar, Len(Cells(I,
1).Value)).Font.Bold = True
End If
BLANKB: Next J
BLANKA: Next I
End Sub

Thanks Dave.

Ken Johnson

 

[Guest]

Thanks Ken and Dave!

I tried the final Macro but was getting a syntax error. However, when I ran
your previous one, Ken, it worked! So many thanks both for your help. I still
can't believe how many people there are out there who are just happy to
assist!

Cheers,
Emily

 

[Ken Johnson]

Hi Emily,
You're welcome.
The error was most likely due to the email producing an unwanted line
break.
Following should be OK, but I suppose it's all history now.

Public Sub HighlightNames()
Application.ScreenUpdating = False
Dim lnLastRowA As Long
Dim lnLastRowB As Long
Dim I As Long
Dim J As Long
Dim lnStartChar As Long
lnLastRowA = _
ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
lnLastRowB = _
ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
For I = 1 To lnLastRowA
If Cells(I, 1) = "" Then GoTo BLANKA
For J = 1 To lnLastRowB
If Cells(J, 2) = "" Then GoTo BLANKB
lnStartChar = InStr(Cells(J, 2).Value, _
Cells(I, 1).Value)
If lnStartChar <> 0 Then
Cells(J, 2).Characters(lnStartChar, _
Len(Cells(I, 1).Value)).Font.Bold = True
End If
BLANKB: Next J
BLANKA: Next I
End Sub

Ken Johnson