Excel VBA 将文本框（文本和格式）复制到另一个文本框（无 ActiveX / 用户表单）

Question

我正在尝试将内容（文本和格式）从一个工作表上的文本框中复制到同一工作簿中另一张工作表上的另一个文本框中。我已经能够成功复制几乎所有内容，但理由（中心/左/右）不适用于每一行。我以一种非常笨拙的方式执行此操作：复制文本，然后遍历每个字符以获取格式集。在 excel vba 中似乎没有一种简单的方法可以复制文本和所有格式。本质上，我正在尝试在原始文本框上执行“全选（Cntrl-A）”，“复制（Cnrl-C）”，然后在目标文本框上执行“特殊粘贴（保留源格式）”。 IT 使用鼠标可以很好地工作，但我不想那样做。我只想运行一个宏来做同样的事情。另外，我注意到当宏运行时，目标文本框对文本应用全局对齐，我不再能够单独选择一行并设置其对齐方式（即所有行居中或所有行左对齐 vs . 能够单独调整每条线）。同样，这种奇怪的行为只发生在宏运行之后。如果我使用鼠标剪切和粘贴方法，文本可以再次逐行对齐。这是我的笨拙代码：

Sub Update_CARD_LEG_BACK()
    ' Set varibles to reduce typing and make changing origin and destination text boxes easier.
    Set Orig = Sheets("MAIN_INPUT2").Shapes("CARD_LEG_BACK")
    Set Orig_Sheet = Sheets("MAIN_INPUT2")
    Set Dest = Sheets("CARD_LEGACY").Shapes("BACK")
    Set Dest_Sheet = Sheets("CARD_LEGACY")

    'Copy text from origin text box to destination text box.  Copies only the text NO formating.
    Dest.TextFrame.Characters.Text = Orig.TextFrame.Characters.Text

    For i = 1 To Len(Orig.TextFrame.Characters.Text)
        Dest.TextFrame.Characters(i, 1).Font.Underline = Orig.TextFrame.Characters(i, 1).Font.Underline
        With Dest.TextFrame2.TextRange.Characters(i, 1)
            .Text = Orig.TextFrame2.TextRange.Characters(i, 1).Text
        With .Font
            .Name = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Name
            .Size = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Size
            .Bold = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Bold
            .Strikethrough = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Strikethrough
            .Superscript = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Superscript
            .Subscript = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Subscript
            .Fill.ForeColor.RGB = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Fill.ForeColor.RGB
            .Fill.BackColor.RGB = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Fill.BackColor.RGB
            .Fill.Visible = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Fill.Visible
            .Fill.Transparency = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Fill.Transparency
        End With
        With .ParagraphFormat
           .BaselineAlignment = Orig.TextFrame2.TextRange.Characters(i, 1).ParagraphFormat.BaselineAlignment
           .SpaceWithin = Orig.TextFrame2.TextRange.Characters(i, 1).ParagraphFormat.SpaceWithin
           .SpaceBefore = Orig.TextFrame2.TextRange.Characters(i, 1).ParagraphFormat.SpaceBefore
           .SpaceAfter = Orig.TextFrame2.TextRange.Characters(i, 1).ParagraphFormat.SpaceAfter
           .IndentLevel = Orig.TextFrame2.TextRange.Characters(i, 1).ParagraphFormat.IndentLevel
           .FirstLineIndent = Orig.TextFrame2.TextRange.Characters(i, 1).ParagraphFormat.FirstLineIndent
           .Alignment = Orig.TextFrame2.TextRange.Characters(i, 1).ParagraphFormat.Alignment
           .HangingPunctuation = Orig.TextFrame2.TextRange.Characters(i, 1).ParagraphFormat.HangingPunctuation
         End With
       End With
    Next i

    'Copy fill color of origin text box to destination text box. Also copies transparancy (required for 'no fill' option to copy correctly).
    Dest.Fill.ForeColor.RGB = Orig.Fill.ForeColor.RGB
    Dest.Fill.Transparency = Orig.Fill.Transparency
End Sub

Answer 1

您可以将第二个替换为第一个的副本：

Sub Tester()

    ReplaceWithCopy Sheet1.Shapes("SourceTB"), Sheet2.Shapes("DestTB")

End Sub


Sub ReplaceWithCopy(shpSrc As Shape, shpDest As Shape)
    Dim nm As String
    
    shpSrc.Copy
    shpDest.Parent.Paste
    With shpDest.Parent.Shapes(shpDest.Parent.Shapes.Count)
        .Left = shpDest.Left
        .Top = shpDest.Top
        .Width = shpDest.Width
        .Height = shpDest.Height
        nm = shpDest.Name
        shpDest.Delete   'remove the shape being replaced
        .Name = nm       'rename copy to just-deleted shape
    End With
End Sub