空白行が1行だったり2行だったり、混在している場合って意外と多いんですよね。以前はページ数が少ないため、地道に行を削除していましたが、作業量が多くなってくると話は別です。
　
マクロで一括置換して業務効率化を図るべく、試行錯誤しました。空白行をすべて削除するのではなく、1行だけ残したい人向けです。

余分な空白行を詰める

連続した2行以上の空白行があるとき、1行にするマクロです。ついでに文書の最後にある空白行も削除します。
　
ワイルドカードを使うためには、「あいまい検索（日）」をオフにする必要があります。「あいまい検索（日）」は既定値がTrueになっており、ワイルドカードとは併用できないため、先にFalseの記述をします。

Sub 連続した空白行を圧縮()
　
Dim allRange As Range
Dim endRange As Range
　
Set allRange = ActiveDocument.Range(0, 0)
Set endRange = ActiveDocument.Range(ActiveDocument.Range.End - 4, ActiveDocument.Range.End - 4)
　
'空白行を1行に詰める
With allRange.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "^13{3,}" '検索する文字列
    .Replacement.Text = "^p^p" '置換後の文字列
    .Wrap = wdFindStop '「文書の初めから検索し直す」をストップ
    .MatchFuzzy = False 'あいまい検索（日）をオフ
    .MatchWildcards = True 'ワイルドカードを使用する
    .Execute Replace:=wdReplaceAll 'すべて置換
End With
　
'最終行の空白行を詰める
With endRange.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "^13{2,}" '検索する文字列
    .Replacement.Text = "" '置換後の文字列
    .Wrap = wdFindStop '「文書の初めから検索し直す」をストップ
    .MatchFuzzy = False 'あいまい検索（日）をオフ
    .MatchWildcards = True 'ワイルドカードを使用する
    .Execute Replace:=wdReplaceAll 'すべて置換
End With
　
Set allRange = Nothing
Set endRange = Nothing
  
End Sub