Add two Characters Objects together so as to concatenate their text but retain formats from each

Question

I am adding the contents of cells to a shape object. The contents are all text, but each cell may have different formatting. I would like to be able to preserve this formatting when adding the content of the cells to the shape, so that a bold cell will appear as such and so on.

I have been trying to take the current Shape.TextFrame.Characters object and add the new Range("TargetCell").Characters object to it, for each target cell in my source range.

Is there a simple way to force two .Characters objects together, so the text concatenates and the formatting changes to reflect the source at the boundary of the new text - I see the .Characters.Insert(string) method, but that only inserts the text, not the formatting. Every time I add a new cell to the output list, I need to recalculate where each portion of text has what formatting, which is proving to be difficult.

I was trying along these lines, but keep coming into difficulties trying to get or set the .Characters(n).Font.Bold property.

Private Sub buildMainText(Target As Range, oSh As Shape)
On Error GoTo 0
Dim chrExistingText As Characters
Dim chrTextToAdd As Characters
Dim chrNewText As Characters
Dim o As Characters
Dim i As Integer
Dim isBold As Boolean
Dim startOfNew As Integer
i = 0
 
  With oSh.TextFrame
    Set chrExistingText = .Characters
    Set chrTextToAdd = Target.Characters
    Set chrNewText = chrTextToAdd
    chrNewText.Text = chrExistingText.Text & chrTextToAdd.Text
    startOfNew = Len(chrExistingText.Text) + 1
    
    .Characters.Text = chrNewText.Text
    
    For i = 1 To Len(chrNewText.Text)
        If i < startOfNew Then
            If chrExistingText(i, 1).Font.Bold Then
                .Characters(i, 1).Font.Bold = True
            Else
                .Characters(i, 1).Font.Bold = False
            End If
        Else
            If chrNewText(i - startOfNew + 1, 1).Font.Bold Then
                .Characters(i, 1).Font.Bold = True
            Else
                .Characters(i, 1).Font.Bold = False
            End If
        End If
    Next i
  End With
End Sub

Answer 1

Here is an example which takes a single cell and appends it to a shape; preserving, shape's and range's formattings. In the example below, we will preserve BOLD (B), ITALICS (I) and UNDERLINE (U). Feel free to modify the code to store more formatting attributes.

LOGIC:

1. The maximum length of characters you can have in a shape's textframe is 32767. So we will create an array (as @SJR mentioned in the comments above) say, TextAr(1 To 32767, 1 To 3), to store the formatting options. The 3 columns are for B,U and I. If you want to add more attributes then change it to the relevant number.
2. Store the shape's formatting in an array.
3. Store the cells's formatting in an array.
4. Append the cell's text to the shape.
5. Loop through the array and re-apply the formatting.

CODE:

I have commented the code but if you have a problem understanding it then simply ask. I quickly wrote this so I must confess that I have not done extensive testing of this code. I am assuming that the cell/shape doesn't have any other formatting other than B, I and U(msoUnderlineSingleLine). If it does, then you will have to amend the code accordingly.

Option Explicit

Sub Sample()
    Dim ws As Worksheet
    
    '~~> Change this to the relevant sheet
    Set ws = Sheet1
    
     AddTextToShape ws.Range("F3"), ws.Shapes("MyShape")
End Sub

'~~> Proc to add cell range to shape
Sub AddTextToShape(rng As Range, shp As Shape)
                  
    '~~> Check for single cell
    If rng.Cells.Count > 1 Then
        MsgBox "Select a single cell and try again"
        Exit Sub
    End If
    
    Dim rngTextLength  As Long
    Dim shpTextLength  As Long
    
    '~~> Get the length of the text in the supplied range
    rngTextLength = Len(rng.Value)
    
    '~~> Get the length of the text in the supplied shape
    shpTextLength = Len(shp.TextFrame.Characters.Text)
    
    '~~> Check if the shape can hold the extra text
    If rngTextLength + shpTextLength > 32767 Then
        MsgBox "Cell text will not fit in Shape. Choose another cell with maximum " & _
        (32767 - shpTextLength) & " characters"
        Exit Sub
    End If
    
    Dim TextAr(1 To 32767, 1 To 3) As String
    Dim i As Long
    
    '~~> Store the value and formatting from the shape in the array
    For i = 1 To shpTextLength
        With shp.TextFrame.Characters(i, 1)
            With .Font
                If .Bold = True Then TextAr(i, 1) = "T" Else TextAr(i, 1) = "F"
                If .Italic = True Then TextAr(i, 2) = "T" Else TextAr(i, 2) = "F"
                If .Underline = xlUnderlineStyleSingle Then TextAr(i, 3) = "T" Else TextAr(i, 3) = "F"
            End With
        End With
    Next i
    
    '~~> Store the value and formatting from the range in the array
    Dim j As Long: j = shpTextLength + 2
    
    For i = 1 To rngTextLength
        With rng.Characters(Start:=i, Length:=1)
            With .Font
                If .Bold = True Then TextAr(j, 1) = "T" Else TextAr(j, 1) = "F"
                If .Italic = True Then TextAr(j, 2) = "T" Else TextAr(j, 2) = "F"
                If .Underline = xlUnderlineStyleSingle Then TextAr(j, 3) = "T" Else TextAr(j, 3) = "F"
                j = j + 1
            End With
        End With
    Next i
    
    '~~> Add the cell text to shape
    shp.TextFrame.Characters.Text = shp.TextFrame.Characters.Text & " " & rng.Value2
    
    '~~> Get the new text length of the shape
    shpTextLength = Len(shp.TextFrame.Characters.Text)
    
    '~~> Apply the formatting
    With shp
        For i = 1 To shpTextLength
            With .TextFrame2.TextRange.Characters(i, 1).Font
                If TextAr(i, 1) = "T" Then .Bold = msoTrue Else .Bold = msoFalse
                
                If TextAr(i, 2) = "T" Then .Italic = msoTrue Else .Italic = msoFalse
                
                If TextAr(i, 3) = "T" Then .UnderlineStyle = msoUnderlineSingleLine _
                Else .UnderlineStyle = msoNoUnderline
            End With
        Next i
    End With
End Sub

IN ACTION