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
Get Text from cell with its format into shape
-
- 4StarLounger
- Posts: 415
- Joined: 29 Mar 2010, 11:50
- Location: Vienna, Austria
Get Text from cell with its format into shape
You do not have the required permissions to view the files attached to this post.
-
- Administrator
- Posts: 78577
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
Re: Get Text from cell with its format into shape
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
Hans
-
- 4StarLounger
- Posts: 415
- Joined: 29 Mar 2010, 11:50
- Location: Vienna, Austria
Re: Get Text from cell with its format into shape
cool, thank you, Hans.