As I said, it's tedious!

This example is quite long so only colour, bold & italic handled, but easy
to extend to cater for the other formats. It could be done with a fraction
of the code but would take a long time to process with a long string (no
mixed formats over 1024).

As written there's a slight difference in how the Insert method handles
formats with new 'replaced' text vs code as written. Comment out the 'If
less 256' stuff to see the difference.

Note the 'Insert method (limited to 255) is actually insert and replace.
This example gives the 'replace' as an option. Also another option to delete
n characters or first instance of a string.

It needs testing far more than I've yet done and if needs correcting. (If
something becomes apparent in the future drop me a line with the
correction.)

Sub InsertMixed(cell As Range, sText As String, nStart As Long, _
Optional bReplace As Boolean, Optional nDelete As Long)
' Insert (or replace) or delete text and conserve mixed font formats
' pmbthornton at gmail dot com

' bReplace -
' false, insert in between existing text
' true, replace same length existing text
' nDelete = true -
' sText = "" to delete nDelete char's from nStart
' sText = "string" with nDelete a number to delete 1 intst' of "string"

Dim i As Long, n As Long
Dim nLen As Long
Dim nC As Long, nB As Long, nI As Long ' color, bold, italic, (temp
counters)
Dim nU&, nS&, nT&, nZ&, nN& 'underline, sub/super script, font size/name

Dim nInsLen As Long, nPos As Long
Dim s$, sL$, sR$
Dim v

s = cell
nLen = Len(s)
If nLen = 0 Then
If Not bDelete Then
rng = sText
End If
Exit Sub
End If

nInsLen = Len(sText)

If nDelete Then
If Len(sText) Then
nPos = InStr(1, s, sText, vbTextCompare)
If nPos = 0 Then Exit Sub
nInsLen = Len(sText)
nDelete = nInsLen
Else
nInsLen = nDelete
End If
nInsLen = -nDelete
sText = ""
bReplace = 0 'True
End If

If nStart = 0 Then nStart = 1

If nLen + nInsLen < 256 And (bReplace Or nDelete 0) Then
If nDelete 0 Then
cell.Characters(nStart, Abs(nInsLen)).Delete
Else
cell.Characters(nStart, nInsLen).Insert sText
End If

Exit Sub
End If


' 3-d array a()
' 1st - position
' 2nd - color, bold, italic
' 3rd - format, length if first change of format else 0

' Increase the 2nd dim to include other formats
' eg - underline, super/sub-script, font size/name
' and use the other temp counters like nU for underline

ReDim a(1 To nLen + nInsLen, 1 To 3, 1 To 2)

If nStart = 1 And bReplace = False Then
n = nInsLen + 1
Else: n = 1
End If


With cell.Font
' if a format is not mixed no need to waste time
' checking each character in the loop
v = .ColorIndex: If Not IsNull(v) Then nC = nLen
v = .Bold: If Not IsNull(v) Then nB = nLen
v = .Italic: If Not IsNull(v) Then nI = nLen
End With

' store the formats
With cell.Characters(1, 1).Font
' start with the first charachter
a(n, 1, 1) = .ColorIndex:
If nC = 0 Then
a(n, 1, 2) = 1: nC = n
Else
a(n, 1, 2) = nC: nC = -1
End If

a(n, 2, 1) = .Bold
If nB = 0 Then
a(n, 2, 2) = 1: nB = n
Else
a(n, 2, 2) = nB: nB = -1
End If

a(n, 3, 1) = .Italic
If nI = 0 Then
a(n, 3, 2) = 1: nI = n
Else
a(n, 3, 2) = nI: nI = -1
End If
End With

For i = 2 To nLen
'loop the rest
n = n + 1
If i = nStart And bReplace = False Then
n = n + nInsLen
If nC 0 Then a(nC, 1, 2) = a(nC, 1, 2) + nInsLen
If nB 0 Then a(nB, 2, 2) = a(nB, 2, 2) + nInsLen
If nI 0 Then a(nI, 3, 2) = a(nI, 3, 2) + nInsLen
End If

With cell.Characters(i, 1).Font
If nC -1 Then
a(n, 1, 1) = .ColorIndex
If a(n, 1, 1) = a(nC, 1, 1) Then
a(nC, 1, 2) = a(nC, 1, 2) + 1
Else
nC = n: a(n, 1, 2) = 1
End If
End If
If nB -1 Then
a(n, 2, 1) = .Bold
If a(n, 2, 1) = a(nB, 2, 1) Then
a(nB, 2, 2) = a(nB, 2, 2) + 1
Else
nB = n: a(n, 2, 2) = 1
End If
End If
If nI -1 Then
a(n, 3, 1) = .Italic
If a(n, 3, 1) = a(nI, 3, 1) Then
a(nI, 3, 2) = a(nI, 3, 2) + 1
Else
nI = n: a(n, 3, 2) = 1
End If
End If
' other formats here
End With
Next

' slice the string
If nDelete 0 Then
If nStart = 1 Then
s = sText & Mid$(s, Abs(nInsLen) + 1, nLen)
ElseIf nStart nLen Then
s = Left$(s, nLen - Abs(nInsLen)) & sText
Else
sL = Left$(s, nStart - 1)
sR = Mid$(s, nStart + Abs(nInsLen), nLen)
s = sL & sText & sR
End If

ElseIf bReplace Then
If nStart = 1 Then
s = sText & Mid$(s, nInsLen + 1, nLen)
ElseIf nStart nLen Then
s = Left$(s, nLen - nInsLen) & sText
Else
sL = Left$(s, nStart - 1)
sR = Mid$(s, nStart + nInsLen, nLen)
s = sL & sText & sR
End If
Else

If nStart = 1 Then
s = sText & s
ElseIf nStart nLen Then
s = s & sText
Else
sL = Left$(s, nStart - 1)
sR = Mid$(s, nStart, nLen)
s = sL & sText & sR
End If
End If

' dump the new string
cell = s

If nStart = 1 And bReplace = False Then
n = nInsLen
Else: n = 0
nLen = Len(s)
End If

' replace the formats
For i = 1 To nLen
n = n + 1
If a(n, 1, 2) And a(n, 1, 2) < nLen - n Then
cell.Characters(n, a(n, 1, 2)).Font.ColorIndex = a(n, 1, 1)
End If
If a(n, 2, 2) And a(n, 2, 2) < nLen - n Then
cell.Characters(n, a(n, 2, 2)).Font.Bold = a(n, 2, 1)
End If
If a(n, 3, 2) And a(n, 3, 2) < nLen - n Then
cell.Characters(n, a(n, 3, 2)).Font.Italic = a(n, 3, 1)
End If
' other formats here
Next

End Sub

Regards,
Peter T


"Erik with a K" wrote in message
...
I'm running into this exact problem where the .Insert method of the
Characters Object doesn't work on a string greater than 255 characters
(nor
does it give an error, it just behaves as if it works and keeps on
going)...
and where splitting the string and adding the new characters loses all
existing rich text formatting. If the only way to make this work is to do
as
you suggested and store all of the data and metadata first, would you have
any pointers or suggestions on how to get started doing this? Do I parse
the
string into some sort of an array?

I read all the way down into Tom's responses as well but I didn't see an
answer though he said he uses other methods... so if anyone has a
suggestion
as to how to insert new characters into a field with greater than 255
characters while preserving existing rich text formatting, your input
would
be greatly appreciated.

"Peter T" wrote:

To preserve existing mixed formats would require storing them all first
then
reapplying, tedious stuff!