Text Highlight

[Paul Mak]

I have an Excel file with over 25,000 row of records in 12 columns. I need
to find and highlight the matching keywords in 3 of the columns. The
keywords is listed in a seperate workbook in the same Excel file. How do I
loop throught all the keywords and highlight the matching one on the other
workbook? I want only the matching keyword highlight but not the entire
cell. The same keyword could occour in more than one instance in the content
of a cell. Thanks a million.

 

[Guest]

dear paul:

I am affraid that excel will not allow you to change the format of only part
of a cell. Still, you could replace it with all uppercase letters...

I believe that what you need is something like this:


Sub highlight()
Dim k As Range
Dim c As Range

For Each k In Range("KEYWORDS")
For Each c In Selection
c.Value = Replace(c.Value, k.Value, UCase(k.Value), 1, -1,
vbTextCompare)
Next c
Next k
End Sub

Or:

Option Compare Text
Sub highlight()
Dim k As Range
Dim c As Range

For Each k In Range("KEYWORDS")
For Each c In Selection
If c.Value Like "*" & k.Value & "*" Then
c.Interior.Color = RGB(255, 255, 0)
End If
Next c
Next k
End Sub

I am sorry that I cannot propose any solution which is exactly like you
needed. Yet, maybe someone else can elaborate on this proposal.


Have a nice day!

Guillermo Morales.

 

[Tim Williams]

You could use .Find to locate all matching cells and then alter the markup.

You definitely *can* modify only part of a cell's content formatting:

With ActiveCell.Characters(Start:=7, Length:=6).Font
.FontStyle = "Bold"
.Color = vbRed
End With

 

[Paul]

Thank you for your reply. If it is possible using "ActiveCell" method, how
to determine the "Start" position in the string. It could have multiple
"Start" positions in a string depending how many times that keyword appears
in the content. Thanks.

 

[Tim Williams]

You could use instr() to find the start position of the first
occurence. It has an optional parameter to specifiy where to start
looking in the string, so set that to the last start position+1 and
keep looking until it's not found.

Tim.

 

[Tim Williams]

This will work for large ranges but you'd probably be better off using
..Find to identify individual cells to pass to the procedure.

Tim

Sub HighLiteText(r As Range, HiliteText As String)
Dim iStart As Long
Dim iFound As Long
Dim s As String
Dim c As Range

For Each c In r

s = c.Value

iStart = 1
iFound = InStr(iStart, s, HiliteText, vbTextCompare)

Do While iFound <> 0
With c.Characters(Start:=iFound, Length:=Len(HiliteText)).Font
.FontStyle = "Bold"
.Color = vbRed
End With
iStart = iFound + 1
iFound = InStr(iStart, s, HiliteText, vbTextCompare)
Loop
Next c
End Sub

 

[Paul Mak]

Hi Tim

Thank you for your suggestion. I know for sure it will work using your code
below. As I am very NEW to Excel programming, please would you advice me how
to identify individual cells to pass to the procedure. Thanks a million!

The following is the one I modified using your original suggestion and it
went into a infinite loop.

Sub FindAndHighlight()
Dim c As Range
Dim iStart As Long
Dim iFound As Long
Dim s As String
Dim db As DAO.Database
Dim rst1 As DAO.Recordset
Dim strKeyword As String

'Loop throught each keyword to find the match text in the Excel file
Set db = CurrentDb
Set rst1 = db.OpenRecordset("SELECT Tbl_CYSN_Keywords.CYSNKeywordID,
Tbl_CYSN_Keywords.CYSNKeyword FROM Tbl_CYSN_Keywords;")
On Error Resume Next
If Not rst1.BOF Then
rst1.MoveFirst
Do While Not rst1.EOF
strKeyword = rst1!CYSNKeyword
Columns("T:V").Select
Cells.Find(What:=strKeyword, After:=ActiveCell,
LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext,
MatchCase:=False, SearchFormat:=False).Activate

For Each c In Selection
s = ActiveCell.Value
iStart = 1
iFound = InStr(iStart, s, strKeyword, vbTextCompare)

Do While iFound <> 0
With c.Characters(Start:=iFound,
Length:=Len(strKeyword)).Font
.FontStyle = "Bold"
.Color = vbRed
End With
iStart = iFound + 1
iFound = InStr(iStart, s, strKeyword,
vbTextCompare)
Loop
Next c 'it went into infinite loop here

rst1.MoveNext
Loop
End If
rst1.Close
Set rst1 = Nothing
Set db = Nothing
End Sub

 

[Tim Williams]

Paul,

There's no need to put all the code into a single routine: it's much
better to keep it sub-divided into individual parts, eahc of which
just does a specific task.

so, assuming your code to fetch your list of keywords is in a separate
sub, your best bet is to create a routine which just finds the
relevant cells and calls the procedure I provided to hilite the cells.

Something like (lifted from MS site):

Sub ProcessMatchesInRange(SearchRange As Range, SearchText As String)
Dim c As Range, firstAddress As String

Set c = SearchRange.Find(SearchText, LookIn:=xlValues, _
LookAt:=xlPart,
MatchCase:=False)
If Not c Is Nothing Then
firstAddress = c.Address
Do
HighLiteText c, SearchText 'my original sub
Set c = SearchRange.FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End Sub

You would in turn call this from within your recordset loop:

.......
Do While Not rst1.EOF
strKeyword = rst1!CYSNKeyword
ProcessMatchesInRange Activesheet.Columns("T:V"),
strKeyword
rst1.MoveNext
Loop
......


Hope that helps
Tim.