Find & Replace : Keep the original format
 

I am trying use replace in a worksheet through the below code.

Cells.Replace What:="ABC", Replacement:="DEF", LookAt:=xlPart,
SearchOrder
:=xlByRows, MatchCase:=False, SearchFormat:=True, ReplaceFormat:=True


The problem is that when replace is done the formatting of the cell becomes
same as of the first character.

example if I have text in a cell with following formatting
(Part 1 - Black regular) (Part 2 - Red Italics) (Part 3 - Black Regular)

when i do replace it changes the whole cell to black regular. Is there a way
to do replace with keeping the original formatting.
--
Ajit

Find & Replace : Keep the original format
 

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


The new word actually takes the attributes of the first letter in the old word.
(I wasn't sure how to handle this if the number of letters in the replacement
word was different than the number of letters in the original word.

DEF replaced with EFGHIJK





Ajit wrote:

I am trying use replace in a worksheet through the below code.

Cells.Replace What:="ABC", Replacement:="DEF", LookAt:=xlPart,
SearchOrder
:=xlByRows, MatchCase:=False, SearchFormat:=True, ReplaceFormat:=True

The problem is that when replace is done the formatting of the cell becomes
same as of the first character.

example if I have text in a cell with following formatting
(Part 1 - Black regular) (Part 2 - Red Italics) (Part 3 - Black Regular)

when i do replace it changes the whole cell to black regular. Is there a way
to do replace with keeping the original formatting.
--
Ajit

--

Dave Peterson

Find & Replace : Keep the original format
 

with wordwrap 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

The new word actually takes the attributes of the first letter in the old word.
(I wasn't sure how to handle this if the number of letters in the replacement
word was different than the number of letters in the original word.

DEF replaced with EFGHIJK

Ajit wrote:

I am trying use replace in a worksheet through the below code.

Cells.Replace What:="ABC", Replacement:="DEF", LookAt:=xlPart,
SearchOrder
:=xlByRows, MatchCase:=False, SearchFormat:=True, ReplaceFormat:=True

The problem is that when replace is done the formatting of the cell becomes
same as of the first character.

example if I have text in a cell with following formatting
(Part 1 - Black regular) (Part 2 - Red Italics) (Part 3 - Black Regular)

when i do replace it changes the whole cell to black regular. Is there a way
to do replace with keeping the original formatting.
--
Ajit

--

Dave Peterson