使用 VBA 检测字符串格式并将其复制到新单元格

Question

见标题；将动态字符串颜色复制到新单元格并保持新格式。

我最初被视为一个问题：

我这样做是为了复制它；我假设这些文本是静态的并且永远不会改变。但显然事实并非如此。基本上，这甚至是一个请求的唯一原因是我们将大量特定单元格复制并粘贴到另一个单元格，显然单独着色的文本字符串不会保持正确的颜色。我确实理解并理解手动编辑它是一种痛苦。显然，该单元格的格式可以是……可变的。所以，我有点不知所措。任何帮助，将不胜感激。这实际上是我第一次尝试 VBA，因此请原谅以下代码可能效率低下：

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