Duplicate pages in quantity to first page

I wanted to duplicate my active page in quantity to the first page. I used the code but it brings error "Object does not support this property or method"

Sub DuplicateToFirstPage()
Dim sr As ShapeRange, nc As Integer, pnext As Page, sduplicate As Shape
nc = InputBox("enter required")
For i = 1 To nc
Set sr = ActivePage.Shapes.All
Set pnext = ActiveDocument.InsertPages(1, False, ActiveDocument.Pages(1))
For Each s In sr.ReverseRange
Set sduplicate = s.Duplicate
sduplicate.MoveToLayer pnext.Layers(s.Layer.Name)
Next s
Next i
pnext.Activate

End Sub

  • Is error appears on this line - sduplicate.MoveToLayer pnext.Layers(s.Layer.Name) ?

    btw, ShapeRange have methods  .Duplicate and .MoveToLayer, no need to do a For-Each loop

  • I tried to duplicate from a particular page (p) to another page (k) but gives me error (type mismatch) in the bold line

    Sub DuplicatePage()
    Dim sr As ShapeRange, nc As Integer, pnext As Page, sduplicate As Shape
    nc = InputBox("enter required no.")
    p = InputBox("enter page from")
    k = InputBox("enter page to")
    For i = 1 To nc
    Set sr = ActiveDocument.Pages(p).Shapes.All
    Set pnext = ActiveDocument.InsertPages(1, False, ActiveDocument.Pages(k).Index)
    For Each s In sr.ReverseRange
    Set sduplicate = sr.Duplicate
    sduplicate.MoveToLayer pnext.Layers(s.Layer.Name)
    Next s
    Next i
    pnext.Activate

    End Sub

  • this also gives me problem.

    Sub DuplicateSelection()
    Dim sr As Shape, nc As Integer, pnext As Page, sduplicate As Shape

    For i = 1 To 1
    Set sr = ActiveSelection
    Set pnext = ActiveDocument.InsertPages(1, False, ActivePage.Index)

    Set sduplicate = sr.Duplicate
    sduplicate.MoveToLayer pnext.ActiveLayer

    Next i
    pnext.Activate

    End Sub

    I want to duplicate an active selection.  the bold line is giving me problem

    • ActiveShape returns shape, ActiveSelectionRange returns some selected shapes as shaperange. 

      • ok.

        but increasing the quantity to 3 brings "type mismatch" error on the bold line

        Sub DuplicateSelection()
        Dim sr As Shape, pnext As Page, sduplicate As Shape

        For i = 1 To 3
        Set sr = ActiveShape
        Set pnext = ActiveDocument.InsertPages(1, False, ActivePage.Index)

        Set sduplicate = sr.Duplicate
        sduplicate.MoveToLayer pnext.ActiveLayer

        Next i
        pnext.Activate

        End Sub

        • you again confuse shape and shaperange

          Dim sr As ShapeRange,  pnext As Page

          Set sr = ActiveSelectionRange  'before loop

          For i = 1 to 3

              Set pnext = ActiveDocument.InsertPages(1, False, ActivePage.Index)

              sr.Duplicate.MoveToLayer pnext.ActiveLayer

          Next

          • ok. the problem is this line. I should have placed it before the loop. thanks

            Set sr = ActiveSelectionRange  'before loop
        • Another challenge is that, if there are no shapes in page "p" it should display the message box but it still went ahead to duplicate empty page

          If ActiveDocument.Pages(p).Shapes.Count = 0 Then
          MsgBox "No objects found on the selected page to duplicate"
          End If

          • may be that page is not have any shapes?

            • I eventually got where i went wrong. I had to put these two lines code together. actually, there were some code in between.

              P = TextBox12.Value
              If ActiveDocument.Pages(P).Shapes.Count = 0 Then MsgBox "No objects found on the specified page to duplicate": Exit Sub

              Thanks.