Macro to bold and change font of specific words in cells in Excel

[jgarner123]

I have a list of words that I need to bold and change the color. For example,

gross proceeds needs to be bold and red
market value needs to be bold and red
enhancing the value needs to be bold and blue
used off needs to be bold and green

I only need exact matches. Also these words can appear multiple times in the same cell. I have used a code that only changes the words the first time they are in the cell - the words might be in the same cell 5 times but only the first instance is fixed. Also this code is only for one specific example so I have to change it and run it several times. I would like to just run it once. In addition to the above 4 examples I have about 30 other combinations.

The code I have used is below:

Sub colorText()

Dim cl As Range

Dim startPos As Integer

Dim totalLen As Integer

Dim searchText As String



' specify text to search. (Change to your needs)

' searchText = [A1]

' searchText = Application.InputBox("enter search text")

searchText = "market value"



' loop trough all cells in selection/range (Change to your needs)

'For Each cl In Range("b:b")

'For Each cl In Selection

'For Each cl In Range("b1", Range("b65536").End(xlUp))

For Each cl In Range("b1:b222")



totalLen = Len(searchText)

startPos = InStr(cl, searchText)



If startPos > 0 Then

With cl.Characters(startPos, totalLen).Font

.FontStyle = "Bold"

.ColorIndex = 10

End With

End If

Next cl

End Sub

 

[jscranton]

I wrote this a long time ago but haven't used it in awhile:

Sub testme()
 
Application.ScreenUpdating = False
 
Dim myWords() As Variant
Dim myRng As Range
Dim foundCell As Range
Dim iCtr As Long 'word counter
Dim cCtr As Long 'character counter
Dim FirstAddress As String
Dim AllFoundCells As Range
Dim myCell As Range
 
'set myWords array to Rang on Worksheet 2
 
    myWords= ThisWorkbook.Worksheets(2).Range("A1:A2")
 
 
Set myRng = Selection
 
On Error Resume Next
Set myRng = Intersect(myRng, _
myRng.Cells.SpecialCells(xlCellTypeConstants, xlTextValues))
On Error GoTo 0
 
If myRng Is Nothing Then
MsgBox "Please choose a range that contains text constants!"
Exit Sub
End If
 
For iCtr = LBound(myWords) To UBound(myWords)
FirstAddress = ""
Set foundCell = Nothing
With myRng
Set foundCell = .Find(what:=myWords(iCtr), _
LookIn:=xlValues, lookat:=xlPart)
 
If foundCell Is Nothing Then
MsgBox myWords(iCtr) & " wasn't found!"
Else
Set AllFoundCells = foundCell
FirstAddress = foundCell.Address
Do
If AllFoundCells Is Nothing Then
Set AllFoundCells = foundCell
Else
Set AllFoundCells = Union(foundCell, AllFoundCells)
End If
Set foundCell = .FindNext(foundCell)
 
Loop While Not foundCell Is Nothing _
And foundCell.Address <> FirstAddress
End If
 
End With
 
If AllFoundCells Is Nothing Then
'do nothing
Else
For Each myCell In AllFoundCells.Cells
For cCtr = 1 To Len(myCell.Value)
If Mid(myCell.Value, cCtr, Len(myWords(iCtr))) _
= myWords(iCtr) Then
myCell.Characters(Start:=cCtr, _
Length:=Len(myWords(iCtr))) _
.Font.ColorIndex = 3
End If
Next cCtr
Next myCell
End If
Next iCtr
Application.ScreenUpdating = True
 
End Sub

 

[jgarner123]

I wrote this a long time ago but haven't used it in awhile:

Sub testme()
 
Application.ScreenUpdating = False
 
Dim myWords() As Variant
Dim myRng As Range
Dim foundCell As Range
Dim iCtr As Long 'word counter
Dim cCtr As Long 'character counter
Dim FirstAddress As String
Dim AllFoundCells As Range
Dim myCell As Range
 
'set myWords array to Rang on Worksheet 2
 
    myWords= ThisWorkbook.Worksheets(2).Range("A1:A2")
 
 
Set myRng = Selection
 
On Error Resume Next
Set myRng = Intersect(myRng, _
myRng.Cells.SpecialCells(xlCellTypeConstants, xlTextValues))
On Error GoTo 0
 
If myRng Is Nothing Then
MsgBox "Please choose a range that contains text constants!"
Exit Sub
End If
 
For iCtr = LBound(myWords) To UBound(myWords)
FirstAddress = ""
Set foundCell = Nothing
With myRng
Set foundCell = .Find(what:=myWords(iCtr), _
LookIn:=xlValues, lookat:=xlPart)
 
If foundCell Is Nothing Then
MsgBox myWords(iCtr) & " wasn't found!"
Else
Set AllFoundCells = foundCell
FirstAddress = foundCell.Address
Do
If AllFoundCells Is Nothing Then
Set AllFoundCells = foundCell
Else
Set AllFoundCells = Union(foundCell, AllFoundCells)
End If
Set foundCell = .FindNext(foundCell)
 
Loop While Not foundCell Is Nothing _
And foundCell.Address <> FirstAddress
End If
 
End With
 
If AllFoundCells Is Nothing Then
'do nothing
Else
For Each myCell In AllFoundCells.Cells
For cCtr = 1 To Len(myCell.Value)
If Mid(myCell.Value, cCtr, Len(myWords(iCtr))) _
= myWords(iCtr) Then
myCell.Characters(Start:=cCtr, _
Length:=Len(myWords(iCtr))) _
.Font.ColorIndex = 3
End If
Next cCtr
Next myCell
End If
Next iCtr
Application.ScreenUpdating = True
 
End Sub

Well, I am struggling - I am great at normal Excel stuff but not at macros...... I am using Excel 2010. Should this work for that? Wish I could attach my workbook... My workbook has a tab called "Clauses". In column B is where I need to run the Macro to change the font. I have a second tab "Lists". In B6:B7 I have examples of words that need to be bold and red. In D6:D7, I have examples of words that need to be bold and blue, etc. You thoughts?

 

[István Hirsch]

Have a look at this macro: excelfindandformat.herobo.com

 

[jscranton]

See if this works for your red coloring:

Sub testme()
 
Application.ScreenUpdating = False
 
Dim myWords() As Variant
Dim myRng As Range
Dim foundCell As Range
Dim iCtr As Long 'word counter
Dim cCtr As Long 'character counter
Dim FirstAddress As String
Dim AllFoundCells As Range
Dim myCell As Range
 
'set myWords array to Rang on Worksheet 2
 
    myWords= ThisWorkbook.Sheets("Lists").Range("B6:B7")
 
 
Set myRng = ThisWorkbook.Sheets("Clauses").Range("B:B")
 
On Error Resume Next
Set myRng = Intersect(myRng, _
myRng.Cells.SpecialCells(xlCellTypeConstants, xlTextValues))
On Error GoTo 0
 
If myRng Is Nothing Then
MsgBox "Please choose a range that contains text constants!"
Exit Sub
End If
 
For iCtr = LBound(myWords) To UBound(myWords)
FirstAddress = ""
Set foundCell = Nothing
With myRng
Set foundCell = .Find(what:=myWords(iCtr), _
LookIn:=xlValues, lookat:=xlPart)
 
If foundCell Is Nothing Then
MsgBox myWords(iCtr) & " wasn't found!"
Else
Set AllFoundCells = foundCell
FirstAddress = foundCell.Address
Do
If AllFoundCells Is Nothing Then
Set AllFoundCells = foundCell
Else
Set AllFoundCells = Union(foundCell, AllFoundCells)
End If
Set foundCell = .FindNext(foundCell)
 
Loop While Not foundCell Is Nothing _
And foundCell.Address <> FirstAddress
End If
 
End With
 
If AllFoundCells Is Nothing Then
'do nothing
Else
For Each myCell In AllFoundCells.Cells
For cCtr = 1 To Len(myCell.Value)
If Mid(myCell.Value, cCtr, Len(myWords(iCtr))) _
= myWords(iCtr) Then
myCell.Characters(Start:=cCtr, _
Length:=Len(myWords(iCtr))) _
.Font.ColorIndex = 3
End If
Next cCtr
Next myCell
End If
Next iCtr
Application.ScreenUpdating = True
 
End Sub

 

[jgarner123]

I got a run time error '13': Type mismatch: myWords = ThisWorkbook.Sheets("Lists").Range("B6:B7")

I have double checked the name and range.

your thoughts?

Thanks!!!

 

[Rick Rothstein]

Here is a macro that I believe will work for you (be sure to read the note at the end)...

Sub ColorCertainWords()
  Dim X As Long, Position As Long, Cell As Range, Words As Variant, Parts() As String
  
[COLOR=#0000FF][B]  Words = Array("gross proceeds//red//3", _
                "market value//red//3", _
                "enhancing the value//blue//5", _
                "used off//green//4")[/B][/COLOR]
                
  For Each Cell In Range("B1", Cells(Rows.Count, "B").End(xlUp))
    If Len(Cell.Value) Then
      For X = LBound(Words) To UBound(Words)
        Parts = Split(Words(X), "//")
        If UBound(Parts) >= 0 Then
          Position = InStr(1, Cell.Value, Parts(0), vbTextCompare)
          Do While Position
            With Cell.Characters(Position, Len(Parts(0))).Font
              .ColorIndex = Parts(2)
              .Bold = True
            End With
            Position = InStr(Position + 1, Cell.Value, Parts(0), vbTextCompare)
          Loop
        End If
      Next
    End If
  Next
  
End Sub

The part of the code that I highlighted in blue is where the word list and its colors are defined. Each word or phrase consists to three parts delimited by a double slash... the text to be colored, a word description for the color to be used (this is for your benefit when you review the code in 6 months) and the ColorIndex number for that color. Since there are several shades of red, green and blue, you may want to change the ColorIndex values I used to one of those other shades... just replace my ColorIndex number with the one you want to use.

 

[jscranton]

Change that line out for this:

myRange = ThisWorkbook.Sheets("Lists").Range("B6:B7")


myWords = myRange

 

[jgarner123]

did I do it correctly? I get run-time error '9': Subscript out of range. Sorry I am such a novice at this!!!!!! But thanks for helping!!!

'set myWords array to Rang on Worksheet 2
 
    myRange = ThisWorkbook.Sheets("Lists").Range("B6:B7")
    
    myWords = myRange
 
 
Set myRng = ThisWorkbook.Sheets("Clauses").Range("B:B")

 

[Rick Rothstein]

did I do it correctly? I get run-time error '9': Subscript out of range. Sorry I am such a novice at this!!!!!! But thanks for helping!!!

I have the impression that you are only reading the last message you see without going back to see if there were other "new" messages before it. I have not reviewed jscranton's code, but I am pretty sure the code I posted in Message #7 will work for you.