Get Text from cell with its format into shape

User avatar
Stefan_Sand
4StarLounger
Posts: 412
Joined: 29 Mar 2010, 11:50
Location: Vienna, Austria

Get Text from cell with its format into shape

Post by Stefan_Sand »

Hello,

I have a macro, where i can put all text from cells in column D into a named shape (Names of shapes in column B)
But i tried some things like using xlPasteAll but nothing works.

For example Hero was here should stay the same text format in the shape and not only text itself.

How do i have to change the lines?

Sub SetShapeText()
' Set the text of the shapes named in column B to the text in column D
Application.Calculation = xlCalculationManual
Dim r As Long
Dim m As Long
Dim shp As Shape
m = Range("B" & Rows.Count).End(xlUp).Row
On Error Resume Next
For r = 3 To m
Set shp = ActiveSheet.Shapes(Range("B" & r))
shp.TextFrame.Characters.Text = Range("D" & r)
Next r
Application.Calculation = xlCalculationAutomatic
End Sub
You do not have the required permissions to view the files attached to this post.

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Get Text from cell with its format into shape

Post by HansV »

Try this:

Code: Select all

Sub SetShapeText()
    ' Set the text of the shapes named in column B to the text in column D
    Dim r As Long
    Dim m As Long
    Dim i As Long
    Dim shp As Shape
    Application.Calculation = xlCalculationManual
    m = Range("B" & Rows.Count).End(xlUp).Row
    On Error Resume Next
    For r = 3 To m
        Set shp = ActiveSheet.Shapes(Range("B" & r))
        shp.TextFrame.Characters.Text = Range("D" & r).Value
        For i = 1 To Len(Range("D" & r).Value)
            With shp.TextFrame.Characters(i, 1).Font
                .Bold = Range("D" & r).Characters(i, 1).Font.Bold
                .Color = Range("D" & r).Characters(i, 1).Font.Color
                .Italic = Range("D" & r).Characters(i, 1).Font.Italic
                .Name = Range("D" & r).Characters(i, 1).Font.Name
                .Size = Range("D" & r).Characters(i, 1).Font.Size
                .Strikethrough = Range("D" & r).Characters(i, 1).Font.Strikethrough
                .Subscript = Range("D" & r).Characters(i, 1).Font.Subscript
                .Superscript = Range("D" & r).Characters(i, 1).Font.Superscript
                .Underline = Range("D" & r).Characters(i, 1).Font.Underline
            End With
        Next i
    Next r
    Application.Calculation = xlCalculationAutomatic
End Sub
Best wishes,
Hans

User avatar
Stefan_Sand
4StarLounger
Posts: 412
Joined: 29 Mar 2010, 11:50
Location: Vienna, Austria

Re: Get Text from cell with its format into shape

Post by Stefan_Sand »

cool, thank you, Hans.