How to append a text to the cell and keep formatting?

Question

I've tried to do it in this really simply way. It works, new text is added to original text, but formatting(bold, etc.) of the original text is lost!

  ActiveSheet.Cells(ActiveCell.Row, 13).Value = ActiveSheet.Cells(ActiveCell.Row, 13) & vbCrLf & Date

Is there any simple solution how to keep the formatting?

Answer 1

I was researching this problem and found a solution on another forum called OzGrid.
(check out the thread at https://www.ozgrid.com/forum/index.php?thread/79710-preserve-cells-word-formatting-concatenating-text/)

A simple way to append to a cell while maintaining previous formatting is to use the .insert method. It inserts new content starting at a designated character, so you need to first determine the index number of the character you want to start your addition at.

Sub AppendToCell()

PreCellCont = ActiveCell.Value   'Stores the content previously in the cell.
ActiveCell.Characters(Len(PreCellCont) + 1).Insert "(Your New Content Here)"
'Inserts new content starting at the character one beyond the number of characters previously in the cell

End Sub

This short code stores the previous contents of the cell to allow us to determine the length. It then inserts the new content starting at the character that will immediately follow the last character of the contents previously in the cell. This index is given by the length of the previous contents plus one.

I hope this is able to help someone else as much as it has helped me!

Answer 2

Only way I have found so far that works reliabily (but very slow) is to save format of each character, append text, and reapply formatting.

I've tried to optimise code by reapplying format to strings of characters but I do not know if this is faster than applying formatting to each character.

eg

call pcExcelCellAppendText(sh.cell(r,3), "start")
call pcExcelCellAppendText(sh.cell(r,3), "red & bold", rgb(&H80,0,0), true)
call pcExcelCellAppendText(sh.cell(r,3), "green", rgb(0,&H80,0))

Sub pcExcelCellAppendText(cell As Excel.Range, word As String, Optional wordColor As Long = 0, Optional wordBold As Boolean = False, Optional wordStrike As Boolean = False)

  ' append word to excel cell

  ' copy current cell formatting

  If cell Is Nothing Then Exit Sub  ' cell not exists

  Dim n As Integer: n = cell.Characters.Count
  Dim s As Integer: s = n + Len(word)

  Dim   clen() As Long:    ReDim   clen(1 To s) ' length of characters with same font  
  Dim  color() As Long:    ReDim  color(1 To s)
  Dim   bold() As Boolean: ReDim   bold(1 To s)
  Dim strike() As Boolean: ReDim strike(1 To s)

  Dim c As Integer
  Dim p As Integer: p = 1

  for c = 1 to n
    With cell.Characters(c, 1).Font
      If          .color =  color(p) _
      and          .bold =   bold(p) _
      and .StrikeThrough = strike(p) Then  ' same format
          clen(p) = clen(p) + 1                ' increase length of characters with same format
      Else                                     ' change of format
                p = c                          ' new base or start of character string
          clen(p) = 1
         color(c) = .color
          bold(c) = .bold
        strike(c) = .StrikeThrough
      End If
    End With

  Next

  ' append word - this resets all formatting so we need to put formatting back

  cell = cell & word

  ' re-apply previous formatting

  c = 1
  While c <= n                         
    With cell.Characters(c, clen(c)).Font   ' restore character font
              .color =  color(c)
               .bold =   bold(c)
      .StrikeThrough = strike(c)
    End With
    c = c + clen(c)
  Wend

  ' highlight appended word

  With cell.Characters(c, Len(word)).Font  ' apply specified font to new text
            .color = wordColor
             .bold = wordBold
    .StrikeThrough = wordStrike
  End With

End Sub

Answer 3

This might do the trick:

ActiveSheet.Cells(ActiveCell.Row, 13).Copy
ActiveSheet.Cells(ActiveCell.Row, 13).Value = ActiveSheet.Cells(ActiveCell.Row, 13) & vbCrLf & Date
ActiveSheet.Cells(ActiveCell.Row, 13).PasteSpecial Paste:=xlPasteFormats

For the line break to show you either need to make sure that the target cell has line break enabled, or you set it by code, like this:

ActiveSheet.Cells(ActiveCell.Row, 13).WrapText = True

Edit: For another approach check @Masouds excelent answer.

Edit: This adds text while preserving all other formatting:

With ActiveCell
    .Characters(Len(.Value) + 1).Insert vbCrLf & Date
End With

Note that the added text fill have the format of the last character in the cell.

Answer 4

Consistent Formatted Cells:

If you don't want to use Copy/Paste you can use something like below:

With ActiveSheet.Cells(ActiveCell.Row, 13)

    With .Font
     f_name = .Name
     f_style = .Style
     f_size = .Size
     f_italic = .Italic
     f_line = .Underline
    End With
   
  .Value = ActiveSheet.Cells(ActiveCell.Row, 13) & vbCrLf & Date

  With .Font
     .Name = f_name
     .Style = f_style
     .Size = f_size
     .Italic = f_italic
     .Underline = f_line
  End With

End With

It is probably even faster than copy/paste but more laborious in terms of scripting (do it the hard way, but the right way).

Partially Formatted Cells:

For partial formatted cells it is a little bit harder. You need to loop through each character. Otherwise, Null will be returned.

With ActiveSheet.Cells(ActiveCell.Row, 13)

For i = 1 To Len(.Value)

   With .Characters(i, 1).Font
     f_name = .Name
     f_style = .Style
     f_size = .Size
     f_italic = .Italic
     f_line = .Underline
   End With

Next i

  .Value = ActiveSheet.Cells(ActiveCell.Row, 13) & vbCrLf & Date

For i = 1 To Len(.Value)

   With .Characters(i, 1).Font
     .Name = f_name
     .Style = f_style 
     .Size = f_size 
     .Italic = f_italic
     .Underline = f_line 
   End With

Next i

End With

The latter satisfies your desired output.