3

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

对于源范围中的每个目标单元格，我一直在尝试获取当前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
4

1 回答 1

2

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

逻辑：

  1. 形状的文本框中可以包含的最大字符长度为32767. 所以我们将创建一个数组（如上面评论中提到的@SJR）说TextAr(1 To 32767, 1 To 3)，来存储格式化选项。列3是B，U和I。如果要添加更多属性，请将其更改为相关编号。
  2. 将形状的格式存储在数组中。
  3. 将单元格的格式存储在数组中。
  4. 将单元格的文本附加到形状。
  5. 循环遍历数组并重新应用格式。

代码：

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

在行动

在此处输入图像描述

于 2020-09-19T18:30:41.833 回答