I wrote this as adjunct to my calendar macro.
It expands/contracts the row height of all rows except the first row of a table, to fit a single page.
Typically I 'm writing up my monthly menu, and since we are into the 10th of the month,
I'll delete those rows preceding the current week,
and then expand the remaining rows to accommodate the space available.
Rather like my trouser belt!

<pre>Private Function FitTableToPage(tbl As Table)
Dim blnBackgroundPagination As Boolean
blnBackgroundPagination = Options.Pagination
Options.Pagination = False
ActiveDocument.Repaginate
'''' DoEvents
Dim lngOriginalPages As Long
lngOriginalPages = ActiveDocument.BuiltInDocumentProperties(wdPropert yPages)
Dim lngIncrement As Long
If lngOriginalPages > 1 Then
lngIncrement = -1
Else
lngIncrement = 1
End If
Dim rng As Range
Set rng = tbl.Range
rng.Start = tbl.Rows(2).Range.Start
rng.Select
While ActiveDocument.BuiltInDocumentProperties(wdPropert yPages) = lngOriginalPages
Selection.Rows.HeightRule = wdRowHeightAtLeast
Selection.Rows.Height = Selection.Rows.Height + lngIncrement
ActiveDocument.Repaginate
DoEvents
Wend
ActiveDocument.Repaginate
DoEvents
Selection.Tables(1).AutoFitBehavior (wdAutoFitWindow)
If Selection.Tables(1).Columns.Count >= 2 Then
Selection.Cells.DistributeWidth
End If
ActiveDocument.Repaginate
DoEvents
Options.Pagination = blnBackgroundPagination
'Sub TESTFitTableToPage()
' Call FitTableToPage(Selection.Tables(1))
'End Sub
End Function</pre>