Sub Reformat()
Application.ScreenUpdating = False
Dim HdFt As HeaderFooter, Rng As Range
With ActiveDocument
  If .Sections.Count > 1 Then
    For Each HdFt In .Sections(.Sections.Count).Headers
      If HdFt.Exists Then
        If Len(.Sections(1).Headers(HdFt.Index).Range) > 1 Then
          HdFt.Range.FormattedText = .Sections(1).Headers(HdFt.Index).Range.FormattedText
          HdFt.Range.Characters.Last.Delete
        End If
      End If
    Next
    For Each HdFt In .Sections(.Sections.Count).Footers
      If HdFt.Exists Then
        If Len(.Sections(1).Footers(HdFt.Index).Range) > 1 Then
          HdFt.Range.FormattedText = .Sections(1).Footers(HdFt.Index).Range.FormattedText
          HdFt.Range.Characters.Last.Delete
        End If
      End If
    Next
  End If
  Do While .Sections.Count > 1
    Set Rng = .Sections(1).Range.Characters.Last
    Rng.Delete
    Rng.InsertBreak Type:=wdPageBreak
    DoEvents
  Loop
  .Range.Characters.Last.Delete
End With
Application.ScreenUpdating = True
End Sub