将两个Characters对象加在一起，以便连接它们的文本，但保留每个对象的格式

问题描述

我正在将单元格的内容添加到形状对象。内容均为文本，但是每个单元格的格式可能不同。在将单元格的内容添加到形状中时，我希望能够保留这种格式，这样粗体单元格将依此类推出现。

我一直在尝试为源范围中的每个目标单元格获取当前的Shape.TextFrame.Characters对象，并向其中添加新的Range("TargetCell").Characters对象。

是否有一种简单的方法可以将两个.Characters对象强制在一起，因此文本会串联起来，格式更改会在新文本的边界处反映源-我看到了.Characters.Insert(string)方法，但是仅插入文本，不插入格式。每次我在输出列表中添加新的单元格时，都需要重新计算文本的每个部分的格式，事实证明这很困难。

我一直在尝试遵循这些原则，但是在尝试获取或设置.Characters(n).Font.Bold属性时会遇到困难。

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 = False
            End If
        End If
    Next i
  End With
End Sub

解决方法

这里是一个示例，该示例将一个单元格附加到形状上；保存，形状和范围的格式。在下面的示例中，我们将保留BOLD (B)，ITALICS (I)和UNDERLINE (U)。随时修改代码以存储更多格式设置属性。

逻辑：

形状的文本框中可以包含的最大字符长度为32767。因此，我们将创建一个数组（如上面的注释中提到的 @SJR ），例如TextAr(1 To 32767,1 To 3)，以存储格式选项。 3列用于B，U和I。如果要添加更多属性，请将其更改为相应的数字。
将形状的格式存储在数组中。
将单元格的格式存储在数组中。
将单元格的文本追加到形状上。
遍历数组并重新应用格式。

代码：

我已经注释了代码，但是如果您在理解代码时遇到问题，则只需询问即可。我很快写了这篇文章，所以我必须承认我没有对该代码进行过广泛的测试。我假设单元格/形状除B，I和U(msoUnderlineSingleLine)之外没有其他格式。如果是这样，那么您将必须相应地修改代码。

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

行动中

excel excel excel-2019 shapes