Find and replace - problem with automatically changing formatting

  • Thread starter Thread starter Guest
  • Start date Start date
G

Guest

Hi,

I'm having a problem with "find and replace" With Italics. If my cell is a
mixture of italics and regular font text and I do a find and replace of a
single word, it automatically changes the formatting to all italics. Does
anyone have a solution for these problems? I have searched HELP and I have
searched the Microsoft Excel and Microsoft Office web sites. NOTHING is
discussed on this formatting problem. HELPPPP!!!! Thanks.
 
Save your file and then try this find and replace macro.
The macro checks the first character of the word/phrase to be changed. If
this is in italics then the new word/phrase will be in italics. All other
text is kept in it's original format with respect to italics.

Sub RepItal()

Dim i As Integer
Dim tLen As Integer
Dim fChar As Integer
Dim fLen As Integer
Dim rLen As Integer
Dim ital() As Boolean
Dim newItal() As Boolean
Dim isItal As Boolean
Dim fVal As String
Dim rVal As String
Dim fNext As Boolean
Dim fCell As Range

fNext = True

fVal = InputBox("Find...")
rVal = InputBox("Replace with...")

Do
If Selection.Count = 1 Then

Set fCell = Cells.Find(What:=fVal, LookIn:=xlValues, _
LookAt:=xlPart, MatchCase:=True)
Else
Set fCell = Selection.Find(What:=fVal, LookIn:=xlValues, _
LookAt:=xlPart, MatchCase:=True)
End If

If Not fCell Is Nothing Then

tLen = Len(fCell.Value)
ReDim ital(tLen - 1) As Boolean
For i = 1 To tLen
ital(i - 1) = fCell.Characters(i, 1).Font.Italic
Next i

fLen = Len(fVal)
rLen = Len(rVal)
fChar = InStr(1, fCell.Value, fVal)
isItal = ital(fChar)
tLen = tLen + (rLen - fLen)
ReDim newItal(tLen - 1) As Boolean
For i = 1 To fChar - 1
newItal(i - 1) = ital(i - 1)
Next i
For i = fChar To (fChar + rLen) - 1
newItal(i - 1) = isItal
Next i
For i = fChar + rLen To UBound(newItal)
newItal(i) = ital(i - (rLen - fLen))
Next i

fCell.Replace What:=fVal, Replacement:=rVal

For i = 1 To UBound(newItal)
fCell.Characters(i, 1).Font.Italic = newItal(i - 1)
Next i
Else
fNext = False
End If

If fNext = True Then
If MsgBox("Continue search?", vbYesNo) = vbNo _
Then fNext = False
End If
Loop While fNext = True

End Sub

Hope this helps
Rowan
 
PS This is case sensitive

Rowan said:
Save your file and then try this find and replace macro.
The macro checks the first character of the word/phrase to be changed. If
this is in italics then the new word/phrase will be in italics. All other
text is kept in it's original format with respect to italics.

Sub RepItal()

Dim i As Integer
Dim tLen As Integer
Dim fChar As Integer
Dim fLen As Integer
Dim rLen As Integer
Dim ital() As Boolean
Dim newItal() As Boolean
Dim isItal As Boolean
Dim fVal As String
Dim rVal As String
Dim fNext As Boolean
Dim fCell As Range

fNext = True

fVal = InputBox("Find...")
rVal = InputBox("Replace with...")

Do
If Selection.Count = 1 Then

Set fCell = Cells.Find(What:=fVal, LookIn:=xlValues, _
LookAt:=xlPart, MatchCase:=True)
Else
Set fCell = Selection.Find(What:=fVal, LookIn:=xlValues, _
LookAt:=xlPart, MatchCase:=True)
End If

If Not fCell Is Nothing Then

tLen = Len(fCell.Value)
ReDim ital(tLen - 1) As Boolean
For i = 1 To tLen
ital(i - 1) = fCell.Characters(i, 1).Font.Italic
Next i

fLen = Len(fVal)
rLen = Len(rVal)
fChar = InStr(1, fCell.Value, fVal)
isItal = ital(fChar)
tLen = tLen + (rLen - fLen)
ReDim newItal(tLen - 1) As Boolean
For i = 1 To fChar - 1
newItal(i - 1) = ital(i - 1)
Next i
For i = fChar To (fChar + rLen) - 1
newItal(i - 1) = isItal
Next i
For i = fChar + rLen To UBound(newItal)
newItal(i) = ital(i - (rLen - fLen))
Next i

fCell.Replace What:=fVal, Replacement:=rVal

For i = 1 To UBound(newItal)
fCell.Characters(i, 1).Font.Italic = newItal(i - 1)
Next i
Else
fNext = False
End If

If fNext = True Then
If MsgBox("Continue search?", vbYesNo) = vbNo _
Then fNext = False
End If
Loop While fNext = True

End Sub

Hope this helps
Rowan
Click to expand...
 
Rowan,

Nice code, but when I tried it was absolutely not case sensitive. Did I miss
something?

Jack Sons
The Netherlands
 
Back
Top