如何将文本追加到单元格并保持格式化?
问题描述:
我试图用这种非常简单的方式来做到这一点。 它的工作原理是将新文本添加到原始文本中,但原始文本的格式(粗体等)丢失了!如何将文本追加到单元格并保持格式化?
ActiveSheet.Cells(ActiveCell.Row, 13).Value = ActiveSheet.Cells(ActiveCell.Row, 13) & vbCrLf & Date
是否有任何简单的解决方案如何保持格式?
答
这可能做的伎俩:
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
注意,所添加的文本填充在细胞中的最后一个字符的格式。
答
一致的格式的单元格:
如果你不想使用复制/粘贴您可以使用类似如下:
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
后者满足您的期望输出。
答
目前我发现的唯一方法是可靠地(但非常慢)工作是保存每个字符的格式,附加文本并重新应用格式。
我试图通过重新应用格式字符串来优化代码,但我不知道这是否比应用格式化每个字符更快。
如
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
希望每个字符(技术上)像以前一样有相同的格式,对不对? – Masoud
是的,原文中的一些重要词汇是大胆的,我想保留它。 – Meloun
您可能想要接受以下答案之一; – Masoud