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

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

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!