VBA - Formatting text inside shapes

[liwi2]

Hi All,
I am not sure where to start with this one. I never worked on code where shapes would be involved and I am not sure if there is solution for what I need.

Basically I have Master sheet with multiple shapes : arrows, rectangles etc. The number of shapes vary from week to week.

What I need is to copy master sheet to new sheet in new workbook,remove all rectangles (that's the easy part) and the part which I don't know how to crack is formatting text inside arrow shapes.
Text is ie: xxxx: yyyyy
zzzzzzzzzzzz
aaaaaaaaaa
bbbbbbbbbb
ccccccccccc

Ideally I need to remove everything till ":", 2nd line and then 4th and 5th line. I could do with removing ALL 1st, 2nd line and then 4th and 5th line if needs be.

I hope someone can help me with above.

Thanks a million

 

[pgc01]

Hi

Let's see if I understand.

You have an arrow shape that has the text:

xxxx: yyyyy
zzzzzzzzzzzz
aaaaaaaaaa
bbbbbbbbbb
ccccccccccc

Ideally I need to remove everything till ":", 2nd line and then 4th and 5th line.

So the final text in the arrow shape is:

yyyyy
aaaaaaaaaa


Is this correct?

 

[liwi2]

That's right. All arrows have five lines of text but I need only
yyyyy
aaaaaaaaaaa

in each of them.
Is it doable?

 

[pgc01]

Try this code for one of the arrow shapes:

Sub EditShpText()
Dim shp As Shape
Dim txtR As TextRange2
Dim s As String
Dim vLines As Variant

Set shp = ActiveSheet.Shapes("MyArrow1")
Set txtR = shp.TextFrame2.TextRange

' initial text in the shape
s = txtR.Text

' removes text up to the first ":"
s = Split(s, ":", 2)(1)

' keeps only lines 1 and 3
vLines = Split(s, vbLf)
s = vLines(0) & vbLf & vLines(2)

'writes the text into the shape
txtR.Text = s

End Sub

 

[liwi2]

Success Thank you so so much
Could you also advise me how I can refer to all arrow shapes in the worksheet so I don't have to call out them by names. Their names always change

 

[pgc01]

What's the autoshape type of your arrows?

 

[liwi2]

All of them have names "Right Arrow x" where x is always a different number

 

[liwi2]

Sorry, names are "y Arrow x" where x is always a different number and y is either "Left" or " Right"

 

[pgc01]

Hi

I was not asking the names, I was asking the autoshape types, but we can also use the names.

This code loops through the shapes in the active sheet and when the shape name contains the string "Arrow" edits the text.

Sub EditAllArrowsText()
Dim shp As Shape

For Each shp In ActiveSheet.Shapes
    If InStr(1, shp.Name, "Arrow", vbTextCompare) > 0 Then EditShpText shp
Next shp

End Sub

Sub EditShpText(shp As Shape)
Dim txtR As TextRange2
Dim s As String
Dim vLines As Variant

Set txtR = shp.TextFrame2.TextRange

' initial text in the shape
s = txtR.Text

' removes text up to the first ":"
s = Split(s, ":", 2)(1)

' keeps only lines 1 and 3
vLines = Split(s, vbLf)
s = vLines(0) & vbLf & vLines(2)

'writes the text into the shape
txtR.Text = s

End Sub

Sub Test()
Dim shp As Shape

Set shp = ActiveSheet.Shapes("MyArrow1")
MsgBox shp.AutoShapeType
End Sub

 

[liwi2]

oh sorry. Shape types are 33 and 34.

I ran above however I got error this time
" Subscript out of range" on line
s = Split(s, ":", 2)(1)