Microsoft Office Forums - View Single Post

gmayor · 12-02-2019, 01:23 AM

I agree with Andrew that you should be using table cells rather than text boxes.
If you add a single column table to a blank document. Type your titles in the cells

and then run the following macro:

Code:

Option Explicit

Sub FitText()
'Graham Mayor - https://www.gmayor.com - Last updated - 02 Dec 2019
Dim oTable As Table
Dim oRng As Range
Dim oCell As Cell
    Set oTable = ActiveDocument.Tables(1)
    With oTable
        .Rows.Height = InchesToPoints(1)
        .TopPadding = InchesToPoints(0)
        .BottomPadding = InchesToPoints(0.25)
        .LeftPadding = InchesToPoints(0.08)
        .RightPadding = InchesToPoints(0.08)
        .Spacing = 0
        .AllowPageBreaks = True
        .AutoFitBehavior wdAutoFitFixed
        .AllowAutoFit = False
    End With
    For Each oCell In oTable.Range.Cells
        oCell.VerticalAlignment = wdCellAlignVerticalCenter
        oCell.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
        Set oRng = oCell.Range
        oRng.End = oRng.End - 1
        If Len(oRng) > 1 Then
            oRng.Font.Size = 72
            Do Until oRng.Characters.Last.Information(wdVerticalPositionRelativeToPage) = _
               oRng.Characters.First.Information(wdVerticalPositionRelativeToPage)
                oRng.Font.Size = oRng.Font.Size - 1
                DoEvents
            Loop
        End If
    Next oCell
lbl_Exit:
    Set oTable = Nothing
    Set oCell = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub

and you should get ...