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

Question

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

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

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

Excel VBA copy Text Box (Text and Format) to another Text Box (no ActiveX / User Forms)

format

excel

vba

textbox

duplicates