fill headings via vba

[wolle271]

cheers guys,

i have a word document and im trying to fill the headings on each page of it. the header looks like this:

12180


my biggest problem is, that i dont know how to access the 3 different parts of the header separately...
so the macro should put something into the header part thats most to the left and then put something different into the centered header part.
does anybody have an idea how to solve this?

[gmayor]

Assuming the image represents a single row table then


Sub FillHeader()
Dim oSection As Section
Dim oHeader As HeaderFooter
Dim oTable As Table
Dim oCell As Range
For Each oSection In ActiveDocument.Sections
For Each oHeader In oSection.Headers
If oHeader.Exists Then
If oHeader.Range.Tables.Count > 0 Then
Set oTable = oHeader.Range.Tables(1)
Set oCell = oTable.Rows(1).Cells(1).Range
oCell.End = oCell.End - 1
oCell.Text = "Left part text"
Set oCell = oTable.Rows(1).Cells(2).Range
oCell.End = oCell.End - 1
oCell.Text = "Middle part text"
Set oCell = oTable.Rows(1).Cells(3).Range
oCell.End = oCell.End - 1
oCell.Text = "Right part text"
End If
End If
Next oHeader
Next oSection
End Sub

The macro shows all three cells. If you only want the left and centre remove the lines

Set oCell = oTable.Rows(1).Cells(3).Range
oCell.End = oCell.End - 1
oCell.Text = "Right part text"

[wolle271]

cheers man,

thx for your reply.
i forgot to mention that im accessing the word document via an excel macro. the document in which these headers need to be written is saved in a variable:




Dim objDocTgt
Set objDocTgt = objWord.Documents.Add("xxx.dotx")



i would be really happy if you could help me.

thx!

[gmayor]

It only needs minor changes primarily with the declarations for it to work in Excel, assuming that the table is already present in the template.


Sub FillHeader()
Dim objWord As Object
Dim objDocTgt As Object
Dim oSection As Object
Dim oHeader As Object
Dim oTable As Object
Dim oCell As Object

On Error Resume Next
Set objWord = GetObject(, "Word.Application")
If Err Then
Set objWord = CreateObject("Word.Application")
End If
On Error GoTo 0
Set objDocTgt = objWord.Documents.Add("C:\Path\xxx.dotx")

For Each oSection In objDocTgt.Sections
For Each oHeader In oSection.Headers
If oHeader.Exists Then
If oHeader.Range.Tables.Count > 0 Then
Set oTable = oHeader.Range.Tables(1)
Set oCell = oTable.Rows(1).Cells(1).Range
oCell.End = oCell.End - 1
oCell.Text = "Left part text" 'Replace with the appropriate value
Set oCell = oTable.Rows(1).Cells(2).Range
oCell.End = oCell.End - 1
oCell.Text = "Middle part text" 'Replace with the appropriate value
Set oCell = oTable.Rows(1).Cells(3).Range
oCell.End = oCell.End - 1
oCell.Text = "Right part text" 'Replace with the appropriate value
End If
End If
Next oHeader
Next oSection
End Sub

[wolle271]

awesome! works fine!