Sub PartPrint()
Application.ScreenUpdating = False
Dim RngPrn As Range, RngSel As Range, oTbl As Table, oCel As Cell, i As Long
With ActiveDocument
  Set RngSel = Selection.Range
  Set RngClr = .GoTo(What:=wdGoToPage, Name:=RngSel.Characters.First.Information(wdActiveEndPageNumber))
  Set RngClr = RngClr.GoTo(What:=wdGoToBookmark, Name:="\page")
  With RngPrn
    .End = RngSel.Start
    .Font.Color = wdColorWhite
    If RngSel.Characters.First.Information(wdWithInTable) = True Then
      For Each oTbl In RngPrn.Tables
        If oTbl.Range.End < RngSel.Tables(RngSel.Tables.Count).Range.End Then
          For Each oCel In oTbl.Range.Cells
            For i = 1 To oCel.Borders.Count
              oCel.Borders(i).Color = wdColorWhite
            Next
          Next
        Else
          For Each oCel In oTbl.Range.Cells
            If oCel.Row.Index < RngSel.Rows.First.Index Then
              For i = 1 To oCel.Borders.Count
                oCel.Borders(i).Color = wdColorWhite
              Next
            End If
          Next
        End If
      Next
    Else
      For Each oTbl In RngPrn.Tables
        For Each oCel In oTbl.Range.Cells
          For i = 1 To oCel.Borders.Count
            oCel.Borders(i).Color = wdColorWhite
          Next
        Next
      Next
    End If
    Application.PrintOut Range:=wdPrintCurrentPage
  End With
  While RngPrn.Font.Color = wdColorWhite
    .Undo
  Wend
  RngSel.Select
End With
Application.ScreenUpdating = True
End Sub