How to copy 15 lines from MS word and paste it to each slide in powerpoint slide?

Question

I'm trying to copy first 15 lines from Word and paste it to Slide(1) in PowerPoint, next 15 lines to Slide(2).....repeat until all texts are copied into PowerPoint. There is only one textbox on each slide. I couldn't figure out how to loop so tried to do in not cool way as following, but in this way, second 15 lines are copied in both Slide(1) and (2). Is there any good way?

Sub test()
Dim pptApp As Object
Dim pptPres As Object
Dim folderPath As String, file As String
Dim shpTextBox As Object

With ActiveDocument
    Selection.HomeKey Unit:=wdStory, Extend:=wdMove
    Selection.MoveDown Unit:=wdLine, Count:=15, Extend:=wdExtend
    Selection.Cut
End With

Set pptApp = CreateObject("PowerPoint.Application")

folderPath = ActiveDocument.Path & Application.PathSeparator
file = "test.pptx"

pptApp.Visible = True
Set pptPres = pptApp.Presentations.Open(folderPath & file)

Set shpTextBox = pptPres.Slides(1).Shapes(1)
shpTextBox.Select

pptApp.CommandBars.ExecuteMso "PasteSourceFormatting"

With ActiveDocument
    Selection.HomeKey Unit:=wdStory, Extend:=wdMove
    Selection.MoveDown Unit:=wdLine, Count:=15, Extend:=wdExtend
    Selection.Cut
End With

pptPres.Slides(2).Select
Set shpTextBox = pptPres.Slides(2).Shapes(1)
shpTextBox.Select

pptApp.CommandBars.ExecuteMso "PasteSourceFormatting"

End Sub

Answer 1

Here is your macro with a loop. There is also a DoEvents loop to allow the operating system time to paste. Otherwise the text doesn't go into the selected placeholder. Depending on your computer's speed, you may have to increase the second number in the DoEvents loop:

Sub CutWordPastePP()
    Dim pptApp As Object
    Dim pptPres As Object
    Dim folderPath As String, file As String
    Dim shpTextBox As Object

    Set pptApp = CreateObject("PowerPoint.Application")
    folderPath = ActiveDocument.Path & Application.PathSeparator
    file = "test.pptx"
    pptApp.Visible = True
    Set pptPres = pptApp.Presentations.Open(folderPath & file)
    x = 1
    Selection.GoTo What:=wdGoToSection, Which:=wdGoToFirst

    Do Until ActiveDocument.Content.Characters.Count = 1
        With Selection
            .HomeKey Unit:=wdStory, Extend:=wdMove
            .MoveDown Unit:=wdLine, Count:=15, Extend:=wdExtend
            .Cut
        End With
        With pptPres
            .Slides(x).Select
            .Slides(x).Shapes(1).Select
        End With
        pptApp.CommandBars.ExecuteMso "PasteSourceFormatting"
        For y = 1 To 6
            DoEvents
        Next y
        x = x + 1
    Loop
End Sub