Multiple Field Properties and Text into Header Table in Word-CodePudding

I am able to update the header of a word doc with the required formatting with the following code:

    Dim myRange As Range
    With ActiveDocument
        Set myRange = .Sections(1).Headers(wdHeaderFooterPrimary).Range
        .Fields.Add Range:=myRange, Type:=wdFieldEmpty, Text:="STYLEREF  Title", PreserveFormatting:=True
        myRange.Collapse wdCollapseStart
        myRange.Text = ""
         myRange.ParagraphFormat.Alignment = wdAlignParagraphRight
           Set myRange = .Sections(1).Headers(wdHeaderFooterPrimary).Range
    myRange.Collapse wdCollapseEnd
    myRange.InsertParagraphAfter
    myRange.Collapse wdCollapseEnd
myRange.Text = "Name: "
    myRange.Collapse wdCollapseEnd
    .Fields.Add Range:=myRange, Type:=wdFieldEmpty, Text:="Name_1", PreserveFormatting:=True
myRange.Fields.Update
Set myRange = .Sections(1).Headers(wdHeaderFooterPrimary).Range
    myRange.Collapse wdCollapseEnd
    myRange.InsertParagraphAfter
    myRange.Collapse wdCollapseEnd
    .Fields.Add Range:=myRange, Type:=wdFieldDate, PreserveFormatting:=True
    myRange.Collapse wdCollapseStart
        myRange.Text = "Date: "
    myRange.Fields.Update
  myRange.ParagraphFormat.Alignment = wdAlignParagraphRight

           Set myRange = .Sections(1).Headers(wdHeaderFooterPrimary).Range
    myRange.Collapse wdCollapseEnd
    myRange.InsertParagraphAfter
    myRange.Collapse wdCollapseEnd
myRange.Text = "Page: "
    myRange.Collapse wdCollapseEnd
               .Fields.Add Range:=myRange, Type:=wdFieldPage, PreserveFormatting:=True
myRange.Fields.Update
    Set myRange = .Sections(1).Headers(wdHeaderFooterPrimary).Range
   myRange.Collapse wdCollapseEnd
myRange.Text = " of "
myRange.Collapse wdCollapseEnd
             .Fields.Add Range:=myRange, Type:=wdFieldNumPages, PreserveFormatting:=True
    myRange.Collapse wdCollapseEnd
             myRange.ParagraphFormat.Alignment = wdAlignParagraphRight
myRange.Fields.Update

End With

I am trying to place the Text and Field Codes from the above code into a table cell within the header section of the word doc using variations of the code below.

Dim MyRange As Range
With ActiveDocument
Set MyRange = ActiveDocument.Sections(1). _
Headers(wdHeaderFooterPrimary). _
Range.Tables(1).Cell(1, 2).Range
MyRange.Collapse wdCollapseStart
MyRange.Fields.Add Range:=MyRange, _
               Type:=wdFieldEmpty, _
               Text:="STYLEREF  Title", _
                             PreserveFormatting:=True
MyRange.InsertParagraphAfter

Set MyRange = ActiveDocument.Sections(1). _
Headers(wdHeaderFooterPrimary). _
Range.Tables(1).Cell(1, 2).Range
MyRange.Collapse wdCollapseEnd
MyRange.Text = "Name: "
MyRange.Collapse wdCollapseEnd
MyRange.Fields.Add Range:=MyRange, _
               Type:=wdFieldEmpty, _
               Text:="Name_1", _
                             PreserveFormatting:=True
Set MyRange = ActiveDocument.Sections(1). _
Headers(wdHeaderFooterPrimary). _
Range.Tables(1).Cell(1, 2).Range
MyRange.Collapse wdCollapseEnd
MyRange.Text = "Date: "
MyRange.Collapse wdCollapseEnd
MyRange.Fields.Add Range:=MyRange, _
               Type:=wdFieldDate, _
                             PreserveFormatting:=True
Set MyRange = ActiveDocument.Sections(1). _
Headers(wdHeaderFooterPrimary). _
Range.Tables(1).Cell(1, 2).Range
MyRange.Collapse wdCollapseEnd
MyRange.Text = "Page: "
MyRange.Collapse wdCollapseEnd
MyRange.Fields.Add Range:=MyRange, _
               Type:=wdFieldPage, _
                             PreserveFormatting:=True
MyRange.InsertParagraphAfter
Set MyRange = ActiveDocument.Sections(1). _
Headers(wdHeaderFooterPrimary). _
Range.Tables(1).Cell(1, 2).Range
MyRange.Collapse wdCollapseEnd
MyRange.Text = "Num Page: "
MyRange.Collapse wdCollapseEnd
MyRange.Fields.Add Range:=MyRange, _
               Type:=wdFieldNumPages, _
                             PreserveFormatting:=True
MyRange.InsertParagraphAfter

The error "This is not a Valid Action for End of Row" appears. It seems to be tied to the "wdCollapseEnd" command and I am unable to retain my desired formatting. Any ideas on how to retain the correct formatting while adding the required field properties with a cell?

CodePudding user response：

One wonders why you're doing this in code instead of using a template with all the boilerplate content in-situ.

That said, your first code block could be reduced to something like:

Sub DemoA()
Application.ScreenUpdating = False
Dim sTb As Single
With ActiveDocument.Sections(1)
  sTb = .PageSetup.PageWidth - .PageSetup.RightMargin - .PageSetup.LeftMargin
  With .Headers(wdHeaderFooterPrimary).Range
    .Text = vbNullString
    .ParagraphFormat.Alignment = wdAlignParagraphCenter
    .Fields.Add Range:=.Characters.Last, Type:=wdFieldEmpty, Text:="STYLEREF Title", PreserveFormatting:=False
    .Characters.Last.Text = vbCr & "Name: "
    .Paragraphs.Last.Range.ParagraphFormat.Alignment = wdAlignParagraphLeft
    .Paragraphs.Last.Range.ParagraphFormat.TabStops.Add Position:=sTb / 2, Alignment:=wdAlignTabCenter
    .Paragraphs.Last.Range.ParagraphFormat.TabStops.Add Position:=sTb, Alignment:=wdAlignTabRight
    .Fields.Add Range:=.Characters.Last, Type:=wdFieldEmpty, Text:="Name_1", PreserveFormatting:=False
    .Characters.Last.Text = vbTab & "Date: "
    .Fields.Add Range:=.Characters.Last, Type:=wdFieldDate, PreserveFormatting:=False
    .Characters.Last.Text = vbTab & "Page: "
    .Fields.Add Range:=.Characters.Last, Type:=wdFieldPage, PreserveFormatting:=False
    .Characters.Last.Text = " of "
    .Fields.Add Range:=.Characters.Last, Type:=wdFieldNumPages, PreserveFormatting:=False
  End With
End With
Application.ScreenUpdating = True
End Sub

For which the table equivalent is:

Sub DemoB()
Application.ScreenUpdating = False
Dim Tbl As Table, Rng As Range
With ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range
  .Text = vbNullString
  Set Tbl = .Tables.Add(Range:=.Duplicate, NumRows:=2, NumColumns:=3)
  Tbl.Rows(1).Cells.Merge
  Tbl.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
  Set Rng = Tbl.Cell(1, 1).Range
  Rng.End = Rng.End - 1
  Rng.Collapse wdCollapseEnd
  .Fields.Add Range:=Rng, Type:=wdFieldEmpty, Text:="STYLEREF Title", PreserveFormatting:=False
  Set Rng = Tbl.Cell(2, 1).Range
  Rng.ParagraphFormat.Alignment = wdAlignParagraphLeft
  Rng.Text = "Name: "
  Rng.End = Rng.End - 1
  Rng.Collapse wdCollapseEnd
  .Fields.Add Range:=Rng, Type:=wdFieldEmpty, Text:="Name_1", PreserveFormatting:=False
  Set Rng = Tbl.Cell(2, 2).Range
  Rng.Text = "Date: "
  Rng.End = Rng.End - 1
  Rng.Collapse wdCollapseEnd
  .Fields.Add Range:=Rng, Type:=wdFieldDate, PreserveFormatting:=False
  Set Rng = Tbl.Cell(2, 3).Range
  Rng.ParagraphFormat.Alignment = wdAlignParagraphRight
  Rng.Text = "Page: "
  Rng.End = Rng.End - 1
  Rng.Collapse wdCollapseEnd
  .Fields.Add Range:=Rng, Type:=wdFieldPage, PreserveFormatting:=False
  Rng.End = Rng.Cells(1).Range.End - 1
  Rng.Collapse wdCollapseEnd
  Rng.Text = " of "
  Rng.Collapse wdCollapseEnd
  .Fields.Add Range:=Rng, Type:=wdFieldNumPages, PreserveFormatting:=False
End With
Application.ScreenUpdating = True
End Sub

or, more simply:

Sub DemoC()
Application.ScreenUpdating = False
With ActiveDocument.Sections(1)
  With .Headers(wdHeaderFooterPrimary).Range
    .Text = vbNullString
    .Fields.Add Range:=.Characters.Last, Type:=wdFieldEmpty, Text:="STYLEREF Title", PreserveFormatting:=False
    .Characters.Last.Text = vbCr & "Name: "
    .Fields.Add Range:=.Characters.Last, Type:=wdFieldEmpty, Text:="Name_1", PreserveFormatting:=False
    .Characters.Last.Text = vbTab & "Date: "
    .Fields.Add Range:=.Characters.Last, Type:=wdFieldDate, PreserveFormatting:=False
    .Characters.Last.Text = vbTab & "Page: "
    .Fields.Add Range:=.Characters.Last, Type:=wdFieldPage, PreserveFormatting:=False
    .Characters.Last.Text = " of "
    .Fields.Add Range:=.Characters.Last, Type:=wdFieldNumPages, PreserveFormatting:=False
    .ConvertToTable Separator:=vbTab
    With .Tables(1)
      .Columns.DistributeWidth
      .Rows(1).Cells.Merge
      .Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
      .Cell(2, 1).Range.ParagraphFormat.Alignment = wdAlignParagraphLeft
      .Cell(2, 3).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
    End With
  End With
End With
Application.ScreenUpdating = True
End Sub

For use with an existing table in the header:

Sub DemoD()
Application.ScreenUpdating = False
Dim Tbl As Table, Rng As Range
With ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range
  Set Tbl = .Tables(1)
  Set Rng = Tbl.Cell(1, 1).Range
  Rng.End = Rng.End - 1
  Rng.Collapse wdCollapseEnd
  .Fields.Add Range:=Rng, Type:=wdFieldEmpty, Text:="STYLEREF Title", PreserveFormatting:=False
  Set Rng = Tbl.Cell(2, 1).Range
  Rng.Text = "Name: "
  Rng.End = Rng.End - 1
  Rng.Collapse wdCollapseEnd
  .Fields.Add Range:=Rng, Type:=wdFieldEmpty, Text:="Name_1", PreserveFormatting:=False
  Set Rng = Tbl.Cell(2, 2).Range
  Rng.Text = "Date: "
  Rng.End = Rng.End - 1
  Rng.Collapse wdCollapseEnd
  .Fields.Add Range:=Rng, Type:=wdFieldDate, PreserveFormatting:=False
  Set Rng = Tbl.Cell(2, 3).Range
  Rng.Text = "Page: "
  Rng.End = Rng.End - 1
  Rng.Collapse wdCollapseEnd
  .Fields.Add Range:=Rng, Type:=wdFieldPage, PreserveFormatting:=False
  Rng.End = Rng.Cells(1).Range.End - 1
  Rng.Collapse wdCollapseEnd
  Rng.Text = " of "
  Rng.Collapse wdCollapseEnd
  .Fields.Add Range:=Rng, Type:=wdFieldNumPages, PreserveFormatting:=False
End With
Application.ScreenUpdating = True
End Sub