Saved from a previous post, but this one has some wordwrap problems fixed:
I think you'd have to keep track of each character's font attributes.
This works very slowly, but works:
Option Explicit
Option Compare Text
Type myCharacter
myChar As String
myLen As Long
myName As String
myFontStyle As String
mySize As Double
myStrikethrough As Boolean
mySuperscript As Boolean
mySubscript As Boolean
myOutlineFont As Boolean
myShadow As Boolean
myUnderline As Long
myColorIndex As Long
End Type
Sub testme()
Application.ScreenUpdating = False
Dim myWords As Variant
Dim myNewWords As Variant
Dim myRng As Range
Dim foundCell As Range
Dim iCtr As Long 'word counter
Dim lCtr As Long 'length of string counter
Dim cCtr As Long 'character counter
Dim usedChars As Long
Dim FirstAddress As String
Dim AllFoundCells As Range
Dim myCell As Range
Dim myStr As String
Dim myCharacters() As myCharacter
myWords = Array("xxx", "yy")
myNewWords = Array("qqqq", "BBBB")
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, _
after:=.Cells(.Cells.Count))
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
ReDim myCharacters(1 To Len(myCell.Value))
usedChars = 0
cCtr = 1
lCtr = 0
Do
usedChars = usedChars + 1
With myCell.Characters(cCtr, 1)
myCharacters(usedChars).myName = .Font.Name
myCharacters(usedChars).myFontStyle = .Font.FontStyle
myCharacters(usedChars).mySize = .Font.Size
myCharacters(usedChars).myStrikethrough _
= .Font.Strikethrough
myCharacters(usedChars).mySuperscript _
= .Font.Superscript
myCharacters(usedChars).mySubscript = .Font.Subscript
myCharacters(usedChars).myOutlineFont _
= .Font.OutlineFont
myCharacters(usedChars).myShadow = .Font.Shadow
myCharacters(usedChars).myUnderline = .Font.Underline
myCharacters(usedChars).myColorIndex = .Font.ColorIndex
If Mid(myCell.Value, cCtr, Len(myWords(iCtr))) _
= myWords(iCtr) Then
myCharacters(usedChars).myChar = myNewWords(iCtr)
myCharacters(usedChars).myLen _
= Len(myNewWords(iCtr))
cCtr = cCtr + Len(myWords(iCtr))
lCtr = lCtr + Len(myNewWords(iCtr))
Else
myCharacters(usedChars).myChar _
= Mid(myCell.Value, cCtr, 1)
myCharacters(usedChars).myLen = 1
cCtr = cCtr + 1
lCtr = lCtr + 1
End If
If cCtr > Len(myCell.Value) Then Exit Do
End With
Loop
myStr = Space(lCtr)
lCtr = 1
For cCtr = 1 To usedChars
Mid(myStr, lCtr, myCharacters(cCtr).myLen) _
= myCharacters(cCtr).myChar
lCtr = lCtr + myCharacters(cCtr).myLen
Next cCtr
myCell.Value = myStr
cCtr = 1
lCtr = 1
Do
With myCell.Characters(lCtr, myCharacters(cCtr).myLen)
.Font.Name = myCharacters(cCtr).myName
.Font.FontStyle = myCharacters(cCtr).myFontStyle
.Font.Size = myCharacters(cCtr).mySize
.Font.Strikethrough _
= myCharacters(cCtr).myStrikethrough
.Font.Superscript = myCharacters(cCtr).mySuperscript
.Font.Subscript = myCharacters(cCtr).mySubscript
.Font.OutlineFont = myCharacters(cCtr).myOutlineFont
.Font.Shadow = myCharacters(cCtr).myShadow
.Font.Underline = myCharacters(cCtr).myUnderline
.Font.ColorIndex = myCharacters(cCtr).myColorIndex
End With
lCtr = lCtr + myCharacters(cCtr).myLen
cCtr = cCtr + 1
If lCtr > Len(myStr) Then
Exit Do
End If
Loop
Next myCell
End If
Next iCtr
Application.ScreenUpdating = True
End Sub
