Sub PrintMe()
Application.ScreenUpdating = False
Dim iStart As Long, iEnd As Long, iCount As Long, StrPages As String
Dim Shp As Shape, i As Long
On Error GoTo Done
With ActiveDocument
  iStart = .Sections.First.Headers(wdHeaderFooterPrimary).PageNumbers.StartingNumber
  If iStart = 0 Then iStart = 1
  iStart = InputBox("What is the First Number?", "Numbering Start From", iStart)
  iEnd = InputBox("What is the Last Number?", "Numbering Stop At", iStart)
  If IsNumeric(iStart) = False Or IsNumeric(iEnd) = False Then GoTo Done
  If iStart > iEnd Or iEnd = 0 Then GoTo Done
  iCount = iEnd - iStart
  For i = 1 To .Paragraphs.Count
    With .Paragraphs(i).Range
      If .Frames.Count = 0 Then
        If .Information(wdWithInTable) = False Then
          .ParagraphFormat.LeftIndent = .Characters.First.Information(wdHorizontalPositionRelativeToTextBoundary) _
            + .PageSetup.LeftMargin - .PageSetup.RightMargin
          .ParagraphFormat.Alignment = wdAlignParagraphLeft
        End If
      End If
    End With
  Next
  With .PageSetup
    .HeaderDistance = 18
    .FooterDistance = 18
    .LeftMargin = .RightMargin
  End With
  For i = .InlineShapes.Count To 1 Step -1
    Set Shp = .InlineShapes(i).ConvertToShape
    With Shp
      .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
      .RelativeVerticalPosition = wdRelativeVerticalPositionPage
      .WrapFormat.Type = wdWrapTight
    End With
  Next
  For Each Shp In .Shapes
    With Shp
      .Anchor.Move wdStory, 1
    End With
  Next
  For i = .Tables.Count To 1 Step -1
    With .Tables(i)
      If Len(Trim(Replace(.Range.Text, Chr(13) & Chr(7), ""))) = 0 Then .Delete
    End With
  Next
  For i = .Frames.Count To 1 Step -1
    With .Frames(i)
      If .Range.Tables.Count = 0 Then .Delete
    End With
  Next
  If Len(.Range.Text) > 1 Then
    .Range.Cut
    With .Sections.First.Headers(wdHeaderFooterPrimary).Range
      .Paste
      For i = 1 To .Paragraphs.Count
        With .Paragraphs(i).Range
          If .Information(wdWithInTable) = False Then
            If Len(.Text) = 1 Then
              With .Font
                .Size = 1
              End With
            Else
              Exit For
            End If
          End If
        End With
      Next
    End With
    With .Sections.First.Footers(wdHeaderFooterPrimary)
      With .PageNumbers
        .Add PageNumberAlignment:=wdAlignPageNumberLeft, FirstPage:=True
        .RestartNumberingAtSection = True
        .StartingNumber = iStart
      End With
      .Range.Fields(1).Code.InsertAfter " \# 0000"
    End With
    With .Styles("Page Number").Font
      .Size = 16
      .Name = "Arial"
      .Bold = True
    End With
  End If
  For iCount = iStart To iEnd - 1
    StrPages = StrPages & Chr(12)
  Next iCount
  .Range.InsertAfter StrPages
  With Application.Dialogs(wdDialogFilePrint)
    If .Show <> True Then iEnd = iStart - 1
  End With
  .Range.Delete
  .Sections.First.Footers(wdHeaderFooterPrimary).PageNumbers.StartingNumber = iEnd + 1
End With
Done:
Application.ScreenUpdating = True
End Sub