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

Question

我正在将单元格的内容添加到形状对象中。内容都是文本，但每个单元格的格式可能不同。我希望在将单元格的内容添加到形状时能够保留此格式，以便粗体单元格将显示为这样等等。

我一直在尝试获取当前 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 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

这是一个示例，它采用单个单元格并将其附加到形状；保留、形状和范围的格式。在下面的示例中，我们将保留 BOLD (B)、ITALICS (I) 和 UNDERLINE (U)。随意修改代码以存储更多格式化属性。

逻辑：

形状的文本框中可以包含的最大字符长度为 32767。所以我们将创建一个数组（如上面评论中提到的@SJR），比如TextAr(1 To 32767, 1 To 3)，来存储格式选项。 3 列用于 B、U 和 I。如果您想添加更多属性，请将其更改为相关数字。
将形状的格式存储在数组中。
将单元格的格式存储在数组中。
将单元格的文本附加到形状。
遍历数组并re-apply格式化。

代码：

我已经对代码进行了评论，但如果您在理解代码时遇到问题，请直接提问。我很快就写了这个，所以我必须承认我没有对这段代码进行过广泛的测试。我假设 cell/shape 除了 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

进行中

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

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

excel

vba

shapes

excel-2019