From one textbox with text make two by VBA

[Kire]

Hello everyone! I'm new in this forume and new in VBA PPT

I would like to ask about how to make from one textbox with bulletpoint lists to several textboxes with one bulletpoint each in one slide?
I can break one textbox with bulletpoint lists to several textboxes, but new textboxes are empty

Could anyone help with this? Thank you in advance!
PPT 2010

[John Wilson]

I'm not sure if this is what you mean.

But try selecting the original textbox and running:

Sub MakeSlides()
Dim oshp As Shape
Dim osldNew As Slide
Dim lngCount As Long
Dim AddHere As Long
On Error GoTo err
Set oshp = ActiveWindow.Selection.ShapeRange(1)
If oshp.HasTextFrame Then
For lngCount = 1 To oshp.TextFrame2.TextRange.Paragraphs.Count
AddHere = oshp.Parent.SlideIndex + lngCount
Set osldNew = ActivePresentation.Slides.Add(AddHere, ppLayoutText)
osldNew.Shapes(2).TextFrame2.TextRange = oshp.TextFrame2.TextRange.Paragraphs(lngCount)
Next lngCount
End If
Exit Sub
err:
MsgBox "Did you select a shape with bulleted text?"
End Sub

[Kire]

John, thank you for your help!
I'm sorry that I wrong wrote what I was meant. The new textboxes should be on the same slide that the general textbox, not on the new. And, if it possible, the Width of new TB is not larger than original.
I've tried to change it by myself, but couldn't understand how

[John Wilson]

I thought you might mean that. Maybe worth saying why you think you need to do it though. Would you want the result to look pretty much as the original??

[Kire]

Would you want the result to look pretty much as the original??

Yes, I would. I saw in some PPT a button that can break one textbox with bulletpoints to several. And it seems very helpful when you do a lot of presentations.
I thought that it's the main button in PPT, but it's not =(. that's why I've been starting to find some information about VBA.

I found code that make same size with two boxes, and think it would help me, but not sure

With ActiveWindow.Selection.ShapeRange(1)
        w = .Width
        h = .Height
        l = .Left
        t = .Top
    End With
    With ActiveWindow.Selection.ShapeRange(2)
        .Width = w
        .Height = h
        .Left = l
        .Top = t
    End With

[John Wilson]

I still don't see WHY you want to do this and I cannot see any advantage.

The code is fairly complex BTW!

[SamT]

Kire.

Do you want to permanently change the slides for use in many presentations?

Or: do you only want to change the TextBoxes during a presentation?

Back to you, John

[Kire]

Sorry, my English not so good, and I can't accurate explain what exactly I need.
I try to explain this:
I have one textbox A with bulletpoint text in slide.
• Text 1
• Text 2
• Text 3

I need split this textbox A into another textboxes that contain one of bulletpoint from the original textbox in each new textbox in the same slide.
The first new textbox contain
• Text 1
The second new textbox contain
• Text 2
The third new textbox contain
• Text 3

[John Wilson]

I think I understand WHAT you need but not WHY.

It's a fair bit of code so ....

[Kire]

It allows easier editing, reordering, changing to a specific layout (like scattered phrases or PPT text table) and splitting into multiple slides

[John Wilson]

I'm not sure it does but you could try this.

Make sure you use a COPY of the presentation and you may need to do some formatting like colours etc.

Sub fixSlide()
Dim oshp As Shape
Dim oTB As Shape
Dim osld As Slide
Dim L As Long
Dim sngT As Single
Dim sngW As Single
Dim sngL As Single
Dim otxR1 As TextRange
Dim FM As Single
Dim LM As Single

Dim fontsz As Long
'On Error GoTo err
Set oshp = ActiveWindow.Selection.ShapeRange(1)
sngL = oshp.Left
sngW = oshp.Width
Set osld = oshp.Parent
fontsz = oshp.TextFrame.TextRange.Paragraphs(1).Font.Size
Set otxR1 = oshp.TextFrame.TextRange.Paragraphs(1)
LM = oshp.TextFrame.Ruler.Levels(1).LeftMargin
FM = oshp.TextFrame.Ruler.Levels(1).FirstMargin
For L = 1 To oshp.TextFrame.TextRange.Paragraphs.Count

If L = 1 Then
sngT = oshp.Top
Else
sngT = otxR1.BoundTop + otxR1.BoundHeight
End If

Set oTB = osld.Shapes.AddTextbox(msoTextOrientationHorizontal, sngL, sngT, sngW, 10)
oTB.TextFrame.TextRange.Text = oshp.TextFrame2.TextRange.Paragraphs(L).Text

Set otxR1 = oTB.TextFrame.TextRange
While Right(otxR1.Text, 1) = Chr(13)
otxR1.Text = Left(otxR1.Text, Len(otxR1.Text) - 1)
Wend

otxR1.ParagraphFormat.Bullet.Visible = _
oshp.TextFrame2.TextRange.Paragraphs(L).ParagraphFormat.Bullet.Visible
otxR1.ParagraphFormat.Bullet.Type = _
oshp.TextFrame.TextRange.Paragraphs(L).ParagraphFormat.Bullet.Type
oTB.TextFrame.TextRange.Font.Size = fontsz
oTB.TextFrame.Ruler.Levels(1).FirstMargin = FM
oTB.TextFrame.Ruler.Levels(1).LeftMargin = LM
Next L
oshp.TextFrame.DeleteText
oshp.Delete
Exit Sub
err:
MsgBox "Error, " & err.Description
End Sub

[Kire]

Thank you, thank you, thank you very much! That's exactly what I need!

Sorry about my misunderstanding "Why"-question!