replace one tag in content of one cell and format not changed

[replace one tag in content of one cell a]

replace one tag in content of one cell and format not changed
I want to replace one tag '#abc#':
for example, the content of cell is: 123#abc#456
the format of '123' is Bold
the color of '456' is red
After replaced these formats of words don't be changed
How can I do?
VBScript?
Now if I use the function of replace, only one format is left

[Dave Peterson]

I think you'll have to loop through each cell.

You'll have to keep track of the formatting for each character that's going to
remain and apply that formatting after you remove the "tag" from the cell.

And since your sample shows only digits remaining, you'll have to make sure that
your cell is formatted as text--real numbers can't have this kind of formatting.

Here's a slightly modified version of a previous post:

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("#abc#")
myNewWords = Array("")

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.NumberFormat = "@"
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

If you're new to macros, you may want to read David McRitchie's intro at:
http://www.mvps.org/dmcritchie/excel/getstarted.htm

replace one tag in content of one cell a wrote:
>
> replace one tag in content of one cell and format not changed
> I want to replace one tag '#abc#':
> for example, the content of cell is: 123#abc#456
> the format of '123' is Bold
> the color of '456' is red
> After replaced these formats of words don't be changed
> How can I do?
> VBScript?
> Now if I use the function of replace, only one format is left

--

Dave Peterson