Split Text Box by Bullets with no extra return

[RayKay]

Hi John

I used this code you kindly created; I can't find how to remove the extra 'return' it puts in each next bullet's text box?
I've experimented, but alas, no luck. Thank you :) and have a super weekend!

Code:


Sub SplitTextBoxes()
Dim oShp As Shape
Dim osld As Slide
Dim L As Long
Dim otr As TextRange2
Dim X As Integer
On Error GoTo err
Set oShp = ActiveWindow.Selection.ShapeRange(1)
Set osld = oShp.Parent
On Error GoTo err
If oShp.HasTextFrame Then
If oShp.TextFrame2.HasText Then
With oShp.TextFrame2.TextRange
For L = 1 To .Paragraphs.Count
Set otr = .Paragraphs(L)
With osld.Shapes.AddTextbox(msoTextOrientationHorizontal, oShp.Left, oShp.Top + X, 400, 15)
.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
.TextFrame2.VerticalAnchor = msoAnchorTop
.TextFrame2.MarginBottom = 0
.TextFrame2.MarginTop = 0
.TextFrame2.MarginLeft = 0
.TextFrame2.MarginRight = 0
With .TextFrame2.TextRange
.Text = otr.Text
.Font.Size = 12
.Font.Bold = False
.ParagraphFormat.Alignment = msoAlignLeft
.ParagraphFormat.Bullet.visible = True
.ParagraphFormat.Bullet.Character = 167
.ParagraphFormat.Bullet.Font.Name = "WingDings"
.ParagraphFormat.Bullet.Font.Fill.ForeColor.RGB = RGB(219, 0, 17)
.ParagraphFormat.LeftIndent = 14.3
.ParagraphFormat.FirstLineIndent = -14.3
End With
X = X + .Height
End With
Next L
End With
End If
End If
oShp.Delete
Exit Sub
err:
MsgBox "Please select a text box"
End Sub

[rodrigolf]

Try this:


Sub Split_Text_Boxes()
Dim oshp As Shape
Dim osld As Slide
Dim L As Long
Dim otr As TextRange2
Dim x As Integer
Set oshp = ActiveWindow.Selection.ShapeRange(1)
Set osld = oshp.Parent
On Error GoTo err
If oshp.HasTextFrame Then
If oshp.TextFrame2.HasText Then
With oshp.TextFrame2.TextRange
For L = 1 To .Paragraphs.Count
Set otr = .Paragraphs(L)
With osld.Shapes.AddTextbox(msoTextOrientationHorizontal, oshp.Left, oshp.Top + x, 400, 15)
.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
.TextFrame2.VerticalAnchor = msoAnchorTop
.TextFrame2.MarginBottom = 0
.TextFrame2.MarginTop = 0
With .TextFrame2.TextRange
.Text = Replace(otr.Text, vbCr, "")
.Font.Size = 12
.Font.Bold = False
.ParagraphFormat.Alignment = msoAlignLeft
End With
x = x + .Height
End With
Next L
End With
End If
End If
oshp.Delete
Exit Sub
err:
MsgBox "Please select a text box"
End Sub