Try this code



VBA Code:
--------------------


Sub ColorCells()

Set Sourcesht = ThisWorkbook.Sheets("Sheet1")
With Sourcesht
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
Set WordRange = .Range("A1:A" & LastRow)
End With

fileToOpen = Application _
.GetOpenFilename("Excel Files (*.xls), *.xls")
If fileToOpen = False Then
MsgBox ("Cannot Open file - Exiting Macro")
End
End If

Set destBk = Workbooks.Open(Filename:=fileToOpen)
For Each sht In destBk.Sheets
For Each wrd In WordRange
Set c = sht.Cells.Find(what:=wrd, _
LookIn:=xlValues, _
lookat:=xlPart)
If Not c Is Nothing Then
FirstAddr = c.Address
Do

With c.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 3
End With
With c.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 3
End With
With c.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 3
End With
With c.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 3
End With


WordLength = Len(wrd)
OldStartPos = 1
Do
'find position of character
StartPos = InStr(OldStartPos, c, wrd)
If StartPos 0 Then
With c.Characters(Start:=StartPos, _
Length:=WordLength).Font

.FontStyle = "Bold"
.ColorIndex = 3
End With

OldStartPos = StartPos + WordLength
End If

Loop While StartPos 0

Set c = sht.Cells.FindNext(after:=c)
Loop While Not c Is Nothing And c.Address < FirstAddr
End If
Next wrd

Next sht

end sub

--------------------


--
joel
------------------------------------------------------------------------
joel's Profile: 229
View this thread: http://www.thecodecage.com/forumz/sh...d.php?t=182954

Microsoft Office Help