使用VBA将格式化字符串复制到新单元格

Question

我想将动态字符串颜色复制到新单元格，保留格式。

我们将许多特定单元格复制并粘贴到另一个单元格，并且单独着色的文本字符串不会保持正确的颜色。

我假设这些文本是静态的。事实并非如此。

Sub FormatCopying()

'turn off green selection
Application.CutCopyMode = False

'copies text
Range("A1:D10").Copy Range("F1:H9")

'copies cell format
Range("A1:D10").Copy
Range("F1:H9").PasteSpecial xlPasteFormats

'turns on green selection; never appeared as it was off and now it is on
Application.CutCopyMode = True

'color red and bold "test to see if I can"
Dim RedColor1 As Long
Dim RedColor1End As Integer

RedColor1 = InStr(1, ActiveCell.Text, "test to see if I can", vbTextCompare)
RedColor1End = Len("test to see if I can")
If RedColor1 > 0 Then ActiveCell.Characters(RedColor1, RedColor1End).Font.Color = RGB(255, 0, 0)
If RedColor1 > 0 Then ActiveCell.Characters(RedColor1, RedColor1End).Font.Bold = True

'color blue and bold "do this"
Dim BlueColor1 As Long
Dim BlueColor1End As Integer

BlueColor1 = InStr(1, ActiveCell.Text, "do this", vbTextCompare)
BlueColor1End = Len("do this")
If BlueColor1 > 0 Then ActiveCell.Characters(BlueColor1, BlueColor1End).Font.Color = RGB(0, 0, 255)
If BlueColor1 > 0 Then ActiveCell.Characters(BlueColor1, BlueColor1End).Font.Bold = True

'color red and bold "Who knows."
Dim RedColor2 As Long
Dim RedColor2End As Integer

RedColor2 = InStr(1, ActiveCell.Text, "Who knows.", vbTextCompare)
RedColor2End = Len("Who knows.")
If RedColor2 > 0 Then ActiveCell.Characters(RedColor2, RedColor2End).Font.Color = RGB(255, 0, 0)
If RedColor2 > 0 Then ActiveCell.Characters(RedColor2, RedColor2End).Font.Bold = True

'color black and bold "Guess we'll find out."
Dim BlackColor1 As Long
Dim BlackColor1End As Integer

BlackColor1 = InStr(1, ActiveCell.Text, "Guess we'll find out.", vbTextCompare)
BlackColor1End = Len("Guess we'll find out.")
If BlackColor1 > 0 Then ActiveCell.Characters(BlackColor1, BlackColor1End).Font.Color = RGB(0, 0, 0)
If BlackColor1 > 0 Then ActiveCell.Characters(BlackColor1, BlackColor1End).Font.Bold = True

End Sub

Answer 1

TLDR，我的方法是有缺陷的，我无法按照同事认为应该采取的方式提供解决方案，但我可以给他们他们想要的结果。我刚刚录制了一个宏来取消合并位置，将原始单元格的左上角复制到目标单元格的左上角，然后重新合并单元格。感谢所有评论和帮助的人！

Sub Merge_FormatCopy()

'Merge_FormatCopy Macro

'Unmerge Origin
    Range("A1:D10").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.UnMerge
    
'Unmerge Destination
    Range("F1:H9").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.UnMerge
    
'Copy Upper Left of Orgin Merged Cell
    Range("A1").Select
    Selection.Copy
    
'Paste Upper Left of Destination Merged Cell
    Range("F1").Select
    ActiveSheet.Paste
    
'Remerge Orign Cells
    Range("A1:D10").Select
    Application.CutCopyMode = False
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
'Remerge Destination Cells
    Selection.Merge
    Range("F1:H9").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
End Sub