Sub FindAndBold()
Dim sFind As String
Dim rCell As Range
Dim rng As Range
Dim lCount As Long
Dim iLen As Integer
Dim iFind As Integer
Dim iStart As Integer

On Error Resume Next
Set rng = ActiveSheet.UsedRange. _
  SpecialCells(xlCellTypeConstants, xlTextValues)
On Error GoTo ErrHandler
If rng Is Nothing Then
    MsgBox "There are no cells with text"
    GoTo ExitHandler
End If

sFind = InputBox( _
  Prompt:="Skriv in dina initialer", _
  Title:="Dina initialer")
If sFind = "" Then
    MsgBox "Du skrev inget"
    GoTo ExitHandler
End If

iLen = Len(sFind)
lCount = 0

For Each rCell In rng
    With rCell
        iFind = InStr(.Value, sFind)
        Do While iFind > 0
            .Characters(iFind, iLen).Font.Bold = True
            .Characters(iFind, iLen).Font.Color = RGB(255, 0, 0)
            .Characters(iFind, iLen).Font.ColorIndex = 4
            lCount = lCount + 1
            iStart = iFind + iLen
            iFind = InStr(iStart, .Value, sFind)
        Loop
    End With
Next

If lCount = 0 Then
    MsgBox "Fanns inget" & _
      vbCrLf & "' " & sFind & " '" & _
      vbCrLf & "att markera"
ElseIf lCount = 1 Then
    MsgBox "Det fanns en" & _
      vbCrLf & "' " & sFind & " '" & _
      vbCrLf & "markerades"
Else
    MsgBox lCount & " hittade" & _
      vbCrLf & "' " & sFind & " '" & _
      vbCrLf & "och markerades"
End If

ExitHandler:
Set rCell = Nothing
Set rng = Nothing
Exit Sub

ErrHandler:
MsgBox Err.Description
Resume ExitHandler