Public Sub setFootersToHeadings()
    Dim doc As Document
    Dim s As Section
    Dim h As HeaderFooter
    Dim p As Paragraph
    Dim page As page
    Dim ctr As Integer
    'ActiveDocument.TablesOfContents(1).Update
           
    Set doc = ActiveDocument
    ctr = 0
    Dim hFound As Boolean
    Dim footerLabel As String
    'footerLable = ""
    Dim tStr As String
           
    For Each s In doc.Sections

        For Each p In s.Range.Paragraphs
            If p.Style = ActiveDocument.Styles("Heading 1") Then
                footerLabel = Left(p.Range.Text, Len(p.Range.Text) - 1)
            End If
                  
            If p.Range.Font.Color = wdColorRed Then
                p.Range.Select
                p.Range.Font.Color = wdColorBlack
            End If
        Next p
               
        'you have a label, assign it to the section

        Set h = s.Footers(1)
        If h.Range.Text <> "Table of Contents" And footerLabel <> "" Then
                   
            h.LinkToPrevious = False
            'set the footer in the section
            'first clean out the old one
            'ctr = h.Range.Text
            tStr = h.Range.Text
              
            'set the footer to the label
            h.Range.Text = Replace(h.Range.Text, tStr, footerLabel)
                         
            With h.PageNumbers
                .Add PageNumberAlignment:=wdAlignPageNumberCenter
                .IncludeChapterNumber = True
                '.ChapterPageSeparator = wdSeparatorEnDash
                .RestartNumberingAtSection = True
                .StartingNumber = 1
            End With
        End If
            If s.PageSetup.Orientation = wdOrientLandscape Then
                
                h.LinkToPrevious = True
                h.PageNumbers.RestartNumberingAtSection = False
            End If

        
    Next s
    ActiveDocument.TablesOfContents(1).Update

    For Each s In doc.Sections
        For Each p In s.Range.Paragraphs
          If p.Style.NameLocal = "Heading 1" Then
                p.Range.Select
                p.Range.Font.Color = wdColorWhite
                p.Range.Font.Size = 5
            End If

            If p.Style.NameLocal = "Heading 2" Then
                p.Range.Select
                p.Range.Font.Color = wdColorWhite
                p.Range.Font.Size = 5
            End If
            If p.Style.NameLocal = "Heading 5" Then
                p.Range.Select
                p.Range.Font.Color = wdColorWhite
                p.Range.Font.Size = 5
            End If

        Next p
    Next s
    

    ActiveDocument.TablesOfContents(2).Update
    ActiveDocument.TablesOfContents(3).Update
         MsgBox ("Done Macro")
          
End Sub

Sub ProcessH1Breaks()
Application.ScreenUpdating = False
Dim Rng1 As Range, Rng2 As Range, Sctn As Section, HdFt As HeaderFooter, i As Long
Set Rng1 = ActiveDocument.Range(0)
Set Rng2 = ActiveDocument.Range(0)
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    'Find all Section breaks
    .Text = "^b"
    .Replacement.Text = "^&"
    'Makes sure the Section break's Style = Normal
    .Replacement.Style = "Normal"
    .Forward = True
    .Wrap = wdFindContinue
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute Replace:=wdReplaceAll
    'Find all "Heading 1" text
    .Text = ""
    .Style = "Heading 1"
    .Wrap = wdFindStop
    .Execute
  End With
  Do While .Find.Found
    Rng1.End = .Duplicate.Start + 1
    Rng2.End = .Duplicate.Start - 1
    'Make sure there is a Next Page Section break before the "Heading 1" paragraph
    If Rng1.Sections.Count = Rng2.Sections.Count Then
      Set Sctn = ActiveDocument.Sections.Add(.Duplicate.Characters.First, wdSectionNewPage)
    Else
      Set Sctn = .Duplicate.Sections.First
    End If
    'Restart the Section's page numbering
    For Each HdFt In Sctn.Headers
      With HdFt
        .LinkToPrevious = False
        .PageNumbers.RestartNumberingAtSection = True
        .PageNumbers.StartingNumber = 1
      End With
    Next
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
  'Repeat making the Sections break Style = Normal
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "^b"
    .Replacement.Text = "^&"
    .Replacement.Style = "Normal"
    .Forward = True
    .Wrap = wdFindContinue
    .Execute Replace:=wdReplaceAll
  End With
  'Make sure all changes in page orientation continue page numbering,
  'PROVIDED the Section doesn't start with Heading 1.
  For i = 2 To .Sections.Count
    If .Sections(i).PageSetup.Orientation <> .Sections(i - 1).PageSetup.Orientation Then
      If .Sections(i).Range.Paragraphs(1).Style <> "Heading 1" Then
        For Each HdFt In .Sections(i).Headers
          With HdFt
            .LinkToPrevious = True
          End With
        Next
      End If
    End If
  Next
End With
Set Rng1 = Nothing: Set Rng2 = Nothing: Set Sctn = Nothing
Application.ScreenUpdating = True
End Sub