如何將文本追加到單元格並保持格式化？

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