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