如何将文本追加到单元格并保持格式化？

Question

我试图用这种非常简单的方式来做到这一点。 它的工作原理是将新文本添加到原始文本中，但原始文本的格式（粗体等）丢失了！

ActiveSheet.Cells(ActiveCell.Row, 13).Value = ActiveSheet.Cells(ActiveCell.Row, 13) & vbCrLf & Date 

是否有任何简单的解决方案如何保持格式？

Answer 1

这可能做的伎俩：

ActiveSheet.Cells(ActiveCell.Row, 13).Copy 
ActiveSheet.Cells(ActiveCell.Row, 13).Value = ActiveSheet.Cells(ActiveCell.Row, 13) & vbCrLf & Date 
ActiveSheet.Cells(ActiveCell.Row, 13).PasteSpecial Paste:=xlPasteFormats 

对于断行要展示你需要确保目标细胞，使线路中断，或者您可以通过代码设置它，像这样：

ActiveSheet.Cells(ActiveCell.Row, 13).WrapText = True 

编辑：另一种方法检查@Masouds优秀的答案。

编辑：这增加了文本，同时保留所有其他格式：

With ActiveCell 
    .Characters(Len(.Value) + 1).Insert vbCrLf & Date 
End With 

注意，所添加的文本填充在细胞中的最后一个字符的格式。

Answer 2

一致的格式的单元格：

如果你不想使用复制/粘贴您可以使用类似如下：

With ActiveSheet.Cells(ActiveCell.Row, 13) 

    With .Font 
    f_name = .Name 
    f_style = .Style 
    f_size = .Size 
    f_italic = .Italic 
    f_line = .Underline 
    End With 

    .Value = ActiveSheet.Cells(ActiveCell.Row, 13) & vbCrLf & Date 

    With .Font 
    .Name = f_name 
    .Style = f_style 
    .Size = f_size 
    .Italic = f_italic 
    .Underline = f_line 
    End With 

End With 

这可能是速度甚至比复制/粘贴，但更费力的脚本的条款（这是艰难的方式，但正确的方式）。

部分格式化细胞：

对于部分格式化的单元格是有点困难。你需要遍历每个角色。否则，将返回Null。

With ActiveSheet.Cells(ActiveCell.Row, 13) 

For i = 1 To Len(.Value) 

    With .Characters(i, 1).Font 
    f_name = .Name 
    f_style = .Style 
    f_size = .Size 
    f_italic = .Italic 
    f_line = .Underline 
    End With 

Next i 

    .Value = ActiveSheet.Cells(ActiveCell.Row, 13) & vbCrLf & Date 

For i = 1 To Len(.Value) 

    With .Characters(i, 1).Font 
    .Name = f_name 
    .Style = f_style 
    .Size = f_size 
    .Italic = f_italic 
    .Underline = f_line 
    End With 

Next i 

End With 

后者满足您的期望输出。

Answer 3

目前我发现的唯一方法是可靠地（但非常慢）工作是保存每个字符的格式，附加文本并重新应用格式。

我试图通过重新应用格式字符串来优化代码，但我不知道这是否比应用格式化每个字符更快。

如

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