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