.Expand Unit:=wdLine

Sub SqueezeText_1012()

    ' rngEndPara identifies the end of the paragraph, then passes it to another
    ' variable (lngLastLineNum); this is so we can determine if a condensed
    ' paragraph has shrunk by a line
    Dim rngEndPara As Range
    ' rngPara is used to apply the condensing and subsequent line-by-line
    ' resetting to no condensing
    Dim rngPara As Range
    Dim lngLastLineNum As Long
    ' Used to increment the condense loop by 0.05 intervals
    Dim iCondense As Single
        
    ' Set the initial range as the current cursor position (Selection.Range)
    Set rngPara = Selection.Range
    ' Expand the range to include the entire paragraph
    rngPara.Expand Unit:=wdParagraph
    
    ' If there is already condensed/expanded text in the paragraph, set it to
    ' none; do this early on, or else the end point might be set on one line,
    ' then, after nixing consensing, the end point is on a different line
    rngPara.Font.Spacing = 0
    
    ' Set the initial range as the current cursor position (Selection.Range)
    Set rngEndPara = Selection.Range
    ' Expand the range to include the entire paragraph
    rngEndPara.Expand Unit:=wdParagraph

    ' Collapse the rngEndPara range to the end of the range so we can eventually
    ' get the line number it's on
    With rngEndPara
        .Collapse direction:=wdCollapseEnd
        ' Because collapsing a paragraph range sets the range to AFTER the
        ' paragraph mark, back it up a character
        .MoveEnd Unit:=wdCharacter, Count:=-1
    End With
    
    ' Set this last-paragraph-line marker
    lngLastLineNum = rngEndPara.Information(wdFirstCharacterLineNumber)
    
    ' Condense the full paragraph range:
    
    ' Set the incrementer to -0.05 (point)
    iCondense = -0.05
    ' Now loop until either the paragraph shrinks one line or we hit a max.
    ' 0.2 pt condensed
    Do Until rngEndPara.Information(wdFirstCharacterLineNumber) = lngLastLineNum - 1 Or rngPara.Font.Spacing = -0.2
        rngPara.Font.Spacing = iCondense ' Condense in -0.05 increments
        iCondense = iCondense + -0.05
    Loop

    ' If after condensing 0.2 point the paragraph's total line count doesn't
    ' decrease, then the paragraph isn't a candidate for condensing, so reset
    ' the spacing to 0.
    If lngLastLineNum = rngEndPara.Information(wdFirstCharacterLineNumber) Then
        rngPara.Font.Spacing = 0
    End If
    
    ' Set the range to just a single line; start at the first line of the paragraph
    With rngPara
        .Collapse direction:=wdCollapseStart
        .Expand Unit:=wdLine
    End With
        
End Sub

Sub MinimizeLastLineWraps()
Application.ScreenUpdating = False
Dim Sctn As Section, Para As Paragraph, Rng As Range, RngTmp As Range, sWdth As Single, sSpc As Single
For Each Sctn In ActiveDocument.Sections
  'Loop through each Section
  With Sctn
    'Get the Section print width
    With .PageSetup
      sWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
    End With
    'Loop through each Paragraph in the Section
    For Each Para In .Range.Paragraphs
      With Para
        Set Rng = .Range
        With Rng
          'Reset the font spacing to 0
          sSpc = 0: .Font.Spacing = sSpc
          'Check whether the paragraph has more than one line; skip one-liners.
          If .Characters.First.Information(wdVerticalPositionRelativeToTextBoundary) <> _
            .Characters.Last.Information(wdVerticalPositionRelativeToTextBoundary) Then
            'Check how far along the line the last character is; we only want to process short last lines.
            'Compress paragraphs with short last lines, up to 1pt.
            Do While .Characters.Last.Information(wdHorizontalPositionRelativeToTextBoundary) < sWdth / 6
              'If the compression exceeds 1pt, re-set & give up.
              If sSpc = -1 Then
                sSpc = 0: .Font.Spacing = sSpc: Exit Do
              End If
              sSpc = sSpc - 0.05: .Font.Spacing = sSpc
            Loop
            If sSpc <> 0 Then
              'Re-check whether the paragraph has more than one line; skip one-liners.
              If .Characters.First.Information(wdVerticalPositionRelativeToTextBoundary) <> _
                .Characters.Last.Information(wdVerticalPositionRelativeToTextBoundary) Then
                'Decompress each line, then apply minimal re-compression to restore then to one line each
                .Collapse wdCollapseStart
                Set RngTmp = .Duplicate
                Do While .End < Para.Range.End
                  Set RngTmp = RngTmp.GoTo(What:=wdGoToLine, Which:=wdGoToNext)
                  .End = RngTmp.Start
                  sSpc = 0: .Font.Spacing = sSpc
                  Do While .Characters.First.Information(wdVerticalPositionRelativeToTextBoundary) <> _
                    .Characters.Last.Information(wdVerticalPositionRelativeToTextBoundary)
                    sSpc = sSpc - 0.05: .Font.Spacing = sSpc
                  Loop
                  .Collapse wdCollapseEnd
                Loop
              End If
            End If
          End If
        End With
      End With
    Next
  End With
Next
Application.ScreenUpdating = True
End Sub

Do While .End < Para.Range.End

For Each Sctn In ActiveDocument.Sections
  'Loop through each Section
  With Sctn
    'Get the Section print width
    With .PageSetup

  With Selection
    'Get the Section print width
    With .Sections.First.PageSetup

Next