CODEWITHSUNDEEP
excelvbaduplicatestextboxformat
Chris
Chris

Reputation: 5

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

I am trying to copy the contents (text and format) from a text box on one sheet to another text box on another sheet within the same workbook. I have been able to successfully copy over almost everything, but the justification (center/left/right) is not working for each individual line. I am doing this in a very clunky way: copy the text, then loop through each character to get the format set. There does not seem to be an easy way in excel vba to copy both the text and ALL of the format over. Essentially I am trying to do a "select all (Cntrl-A)", "copy (Cnrl-C)" on the origin textbox, then do a "paste special (keep source formatting)" on the destination text box. IT works wonderfully using the mouse, but I do not want to do that. I just want to run a macro to do the same thing. Also, I noted that when the macro runs, the destination text box applies justification global to the text and I am no longer able to individually select a single line and set its justification (i.e. either all lines are centered or all lines are left justified vs. being able to adjust each line individually). Again, this weird behavior only happens after the macro is run. If I use the mouse cut-and-paste method, the text is able to be justified line-by-line again. Here is my clunky code:

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

Upvotes: 0

Views: 1282

Answers (1)

Tim Williams
Tim Williams

Reputation: 166531

You could replace the second with a copy of the first:

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

Upvotes: 0

Related Questions