Insert Characters in cell with formatted text

[MichaB]

Hello Community,

I've got a problem with a large Excel-Sheet filled mainly with text.
Each cell contains a formated text (bold, underline, color, ...) with
manual line-wraps (made with ALT-Enter). So far everything works fine,
but now I'm trying to add text to this cell. My first try was

cells(a,b).value =cells(a,b).value + NewText

This set all formats to the format of the first line of cell.

For the next approach I tried using the CHARACTERS-Property.

DLen = Worksheets("LOP").Range("F37").Characters.Count
Set DCh = Worksheets("LOP").Range("F37").Characters(DLen-1, 0)
DCh.Insert NewText

This worked perfectly, except that it only worked for cells with less
than 255 characters. Unfortunately most of the cells have more than 500
characters, even up to 2000 characters. With cells larger than 255
characters simply nothing happened.

Has anyone an idea how to add text to a large cell without destroying
the existing formats?

Thanks in advance.

MichaB

 

[Ron Rosenfeld]

Hello Community,

I've got a problem with a large Excel-Sheet filled mainly with text.
Each cell contains a formated text (bold, underline, color, ...) with
manual line-wraps (made with ALT-Enter). So far everything works fine,
but now I'm trying to add text to this cell. My first try was

cells(a,b).value =cells(a,b).value + NewText

This set all formats to the format of the first line of cell.

For the next approach I tried using the CHARACTERS-Property.

DLen = Worksheets("LOP").Range("F37").Characters.Count
Set DCh = Worksheets("LOP").Range("F37").Characters(DLen-1, 0)
DCh.Insert NewText

This worked perfectly, except that it only worked for cells with less
than 255 characters. Unfortunately most of the cells have more than 500
characters, even up to 2000 characters. With cells larger than 255
characters simply nothing happened.

Has anyone an idea how to add text to a large cell without destroying
the existing formats?

Thanks in advance.

MichaB

Not sure what you are asking.

c.value = c.value & NewText

or

c.value = c.text & NewText

does not change the cell format on my system.

If you mean that you have different formats for different parts of the string,
in the same cell, then I believe you will have to reset them after writing the
new string to the cell.


--ron

 

[Guest]

Hi, try this:

current_text = Cells(1, 1).Text
my_text = current_text & "something"
Cells(1, 1).FormulaR1C1 = my_text

Henrich

„MichaB" napísal (napísala):

 

[MichaB]

If you mean that you have different formats for different parts of the string,

in the same cell, then I believe you will have to reset them after writing the
new string to the cell.

That's exactly my problem, that the text in the cell has different
formats for different parts of the string. I want to avoid that these
"local formats" get lost, because I don't think I can recover them.

MichaB

 

[MichaB]

Hello Henrich,

unfortunately it didn't work. The result is that the complete cell has
now the format "BOLD, UNDERLINE" like the first line. But before, only
the first line had this format, in the second line, part of the text
was UNDERLINED and the rest of the text was just plain text. Is there
any opportunity to add a picture to this message? If yes I can show you
both, before and after.

By the way, what does "napísal/napisala" mean? Is this Spanish? Or
Portoguise?

MichaB

 

[Dave Peterson]

I think you'll have to keep track of the characteristics you want to
keep--character by character. Then append the text, then reapply those
characteristics.

And what should happen to that text that is appended? Should it inherit the
same formatting as the last character in the cell (like characters().insert
works) or do you want to set it to a default format?

Anyway, this (very slow working macro when the text is quite large) may help
you:

Option Explicit
Type myCharacter
myChar As String
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 testme01()
Dim myCell As Range
Dim myText As String

Set myCell = ActiveSheet.Range("a2")
myText = "QWER"

If (Len(myCell.Value) + Len(myText)) < 256 Then
myCell.Characters(Len(myCell.Value) + 1, 1).Insert myText
Else
Call AppendKeepFormatting(myCell, myText)
End If

End Sub
Sub AppendKeepFormatting(myCell As Range, myString As String)

Dim cCtr As Long 'character counter
Dim LastChar As Long

LastChar = Len(myCell.Value)
Dim myCharacters() As myCharacter

ReDim myCharacters(1 To LastChar)

For cCtr = 1 To LastChar
With myCell.Characters(cCtr, 1)
myCharacters(cCtr).myName = .Font.Name
myCharacters(cCtr).myFontStyle = .Font.FontStyle
myCharacters(cCtr).mySize = .Font.Size
myCharacters(cCtr).myStrikethrough = .Font.Strikethrough
myCharacters(cCtr).mySuperscript = .Font.Superscript
myCharacters(cCtr).mySubscript = .Font.Subscript
myCharacters(cCtr).myOutlineFont = .Font.OutlineFont
myCharacters(cCtr).myShadow = .Font.Shadow
myCharacters(cCtr).myUnderline = .Font.Underline
myCharacters(cCtr).myColorIndex = .Font.ColorIndex
End With
Next cCtr

myCell.Value = myCell.Value & myString

For cCtr = 1 To LastChar
With myCell.Characters(cCtr, 1)
.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
Next cCtr

For cCtr = LastChar + 1 To Len(myCell.Value)
With myCell.Characters(LastChar + 1, Len(myCell.Value) - LastChar)
.Font.Name = myCharacters(1).myName
.Font.FontStyle = myCharacters(1).myFontStyle
.Font.Size = myCharacters(1).mySize
.Font.Strikethrough = myCharacters(1).myStrikethrough
.Font.Superscript = myCharacters(1).mySuperscript
.Font.Subscript = myCharacters(1).mySubscript
.Font.OutlineFont = myCharacters(1).myOutlineFont
.Font.Shadow = myCharacters(1).myShadow
.Font.Underline = myCharacters(1).myUnderline
.Font.ColorIndex = myCharacters(1).myColorIndex
End With
Next cCtr
End Sub

 

[Ron Rosenfeld]

That's exactly my problem, that the text in the cell has different
formats for different parts of the string. I want to avoid that these
"local formats" get lost, because I don't think I can recover them.

MichaB

As I wrote, you will have to reset the formats each time you expand the string.
Somehow you will need to keep track of the formats for the differing segments
of this string; or detect them.

Dave posted some code that may be of use to you in this regard.
--ron

 

[MichaB]

Hello Dave,

thank you very much, this way it works, but you're right, it's really
slow, even if I reduce the properties down to 3 instead of 10 (~20
seconds for one 1000 character cell). Is there no way to just copy the
complete FONT-Information in one object?

 

[Dave Peterson]

Not that I know.

Hello Dave,

thank you very much, this way it works, but you're right, it's really
slow, even if I reduce the properties down to 3 instead of 10 (~20
seconds for one 1000 character cell). Is there no way to just copy the
complete FONT-Information in one object?