Make list of words bold in all cells automatically

[DimisEL]

I have an excel file with a dozen of sheets, each of them containing a few decades of cells with text strings in greek.
I need a code that will recognize a list of about 50 greek words in all sheets and will turn them into bold, no matter how many times they occur in every cell.
I know that this thread has been discussed a lot, but no solution could do the job for my purpose.
Any help, suggestion would be highly appreciable.

 

[mikerickson]

What kind of text strings are involved?
Is there punctuation to consider?
Is this a one time thing or are you adding new text strings to this file and want them automatically bolded as you add them?

 

[DimisEL]

Thank you for you kind reply
The answer is yes to both answers.
Greek involves punctuation. Also, new data will be constantly added, which should be scanned for the presence of the words in my list, in order to be highlighted automatically.

 

[mikerickson]

There are a couple of things to keep in mind.

1) If a cell contains a formula, bolding part of the cell's displayed text is not possible. So these routines will not change the appearance of any cell that contains a formula.

2) The list of words to make bold is hard coded in this. That can be changed.

3) The list of characters that this routine considered punctuation can be changed to match your need.

4) You should run the Start sub. That will bold all the appropriate strings in the workbook. Thereafter, the Change event will handle any user entry.

' in normal module

Const Punctuation As String = ".,?!;:"
Const WordsToBold As String = "ham dog"

Sub Start()
    doOneWorkbook ActiveWorkbook
End Sub

Sub doOneWorkbook(theWorkbook As Workbook)
    Dim oneSheet As Worksheet
    For Each oneSheet In theWorkbook.Worksheets
        DoOneSheet oneSheet
    Next oneSheet
End Sub

Sub DoOneSheet(theWorksheet As Worksheet)
    Dim oneCell As Range
    For Each oneCell In theWorksheet.UsedRange.Cells
        DoOneCell oneCell
    Next oneCell
End Sub

Sub DoOneCell(theCell As Range)
    Dim strBold As Variant
    Dim baseText As String, WorkText As String
    Dim FoundPlace As Long, i As Long
    
    baseText = " " & LCase(theCell.Cells(1, 1).Text) & " "
    For i = 1 To Len(Punctuation)
        baseText = Replace(baseText, Mid(Punctuation, i, 1), " ")
    Next i
    theCell.Font.Bold = False
    
    For Each strBold In Split(WordsToBold, " ")
    
        WorkText = baseText
        Do
            FoundPlace = InStrRev(WorkText, " " & strBold & " ", -1, vbTextCompare)
            
            If FoundPlace <> 0 Then
                WorkText = Left(WorkText, FoundPlace - 1)
                theCell.Characters(FoundPlace, Len(strBold)).Bold = True
            End If
        Loop Until FoundPlace <= 0
    Next strBold
End Sub

' in the ThisWorkbook code module

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim oneCell As Range
    For Each oneCell In Target.Cells
        DoOneCell oneCell
    Next oneCell
End Sub