Setting running headers just for the selected section

A

andreas

Dear Experts:

Below macro sets a running header (alternately chapter title level 1
and 2 as well as page number) for ALL sections. It is running just
fine.

How do I have to change the macro so that ONLY the selected section
(where the cursor currently resides) gets a running header and NOT all
the sections?

The exact requirement is as follows:

A msgbox is to inform that the cursor currently resides in SECTION X
and will get a running header after pressing ok. Is this possible
provided that the 'range object' for the setting of the headers is
still used?.

Help is much appreciated. Thank you very much in advance. Regards,
Andreas






Sub Set_Running_Headers_All_Sect()

Dim rng As range
Dim sect As Section

If MsgBox("This macro inserts a running header for all sections" &
vbCrLf & _
"Would you like to continue?", vbYesNo + vbInformation,
"Alternating headers for main sections (e.g. 1 Implementation, 1.1
Analysis)") = vbNo Then
Exit Sub
Else


For Each sect In ActiveDocument.Sections
'Different odd- and even-page and first page headers for the whole
document
sect.PageSetup.OddAndEvenPagesHeaderFooter = True
sect.PageSetup.DifferentFirstPageHeaderFooter = True



Set rng = sect.range
'Get the start of the section
rng.Collapse wdCollapseStart

If rng.Information(wdActiveEndAdjustedPageNumber) Mod 2 = 1
Then
'MOD gets the remainder after dividing by 2
'If it's 0, then it's an even page number
'If the first first page header starts on an even page number
the
'headers are set as follows


'DO FIRST PAGE HEADERS
Set rng = sect.Headers(wdHeaderFooterFirstPage).range

rng.Fields.Add rng, Type:=wdFieldEmpty, Text:="STYLEREF 1 \n "
rng.Collapse wdCollapseEnd
rng.Text = " "
rng.Collapse wdCollapseEnd


rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
"PAGE \* Arabic "

rng.Text = vbTab
rng.Collapse wdCollapseStart

rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
" STYLEREF 1 "


'DO EVEN PAGE HEADERS
Set rng = sect.Headers(wdHeaderFooterEvenPages).range

rng.Fields.Add rng, Type:=wdFieldEmpty, Text:="STYLEREF 1 \n "
rng.Collapse wdCollapseEnd
rng.Text = " "
'Alternatively spaces can be replaced with a tab stop
'rng.Text = vbTab
rng.Collapse wdCollapseEnd

rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
"PAGE \* Arabic "
'rng.Text = vbTab
'rng.Text = "Seite "
rng.Collapse wdCollapseStart
rng.Text = vbTab
rng.Collapse wdCollapseStart


rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
" STYLEREF 1 "


ActiveDocument.UndoClear

'DO ODD PAGE HEADERS
sect.Headers(wdHeaderFooterPrimary).PageNumbers.NumberStyle =
wdPageNumberStyleArabic
sect.Headers(wdHeaderFooterPrimary).PageNumbers.IncludeChapterNumber
= False
Set rng = sect.Headers(wdHeaderFooterPrimary).range

rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
"STYLEREF 2 \n "
rng.Collapse wdCollapseEnd

rng.Text = " "
rng.Collapse wdCollapseEnd


rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
"PAGE \* Arabic "

rng.Text = vbTab
'rng.Text = " "
rng.Collapse wdCollapseStart


rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
" STYLEREF 2 "


Else

'DO FIRST PAGE HEADERS

Set rng = sect.Headers(wdHeaderFooterFirstPage).range

rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
"STYLEREF 2 \n "
rng.Collapse wdCollapseEnd
rng.Text = vbTab
rng.Collapse wdCollapseEnd


rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
"PAGE \* Arabic "

rng.Text = " "
rng.Collapse wdCollapseStart


rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
" STYLEREF 2 "

'DO EVEN PAGE HEADERS
Set rng = sect.Headers(wdHeaderFooterEvenPages).range
sect.Headers(wdHeaderFooterEvenPages).PageNumbers.NumberStyle =
wdPageNumberStyleArabic
sect.Headers
(wdHeaderFooterEvenPages).PageNumbers.IncludeChapterNumber = False

rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
"STYLEREF 2 \n "
rng.Collapse wdCollapseEnd
rng.Text = " "
rng.Collapse wdCollapseEnd


rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
"PAGE \* Arabic "

rng.Text = vbTab
'rng.Text = " "
rng.Collapse wdCollapseStart


rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
" STYLEREF 2 "



ActiveDocument.UndoClear
'DO ODD PAGE HEADERS
sect.Headers(wdHeaderFooterPrimary).PageNumbers.NumberStyle =
wdPageNumberStyleArabic
sect.Headers(wdHeaderFooterPrimary).PageNumbers.IncludeChapterNumber =
False
Set rng = sect.Headers(wdHeaderFooterPrimary).range

rng.Fields.Add rng, Type:=wdFieldEmpty, Text:="STYLEREF 1 \n"
rng.Collapse wdCollapseEnd
rng.Text = " "


rng.Text = vbTab
rng.Collapse wdCollapseEnd


rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
"PAGE \* Arabic "


rng.Text = vbTab
rng.Collapse wdCollapseStart


rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
" STYLEREF 1 "



End If


Next sect

End If

Application.ScreenUpdating = True

End Sub
 
P

Pesach Shelnitz

Hi Andreas,

Your macro has a For Each loop that cycles through all the sections in the
active document.

For Each sect In ActiveDocument.Sections
...
Next

Replace the lines that begin and end this loop by the following With
statements.

With Selection.Sections(1)
...
End With

Then replace sect.PropertyOrMethod with .PropertyOrMethod and delete the
declaration of sect.

Also, in both macros, you should add the following line after the rng object
is no longer needed.

Set rng = Nothing

Write back if you need more help.
 
A

andreas-hermle

Hi Andreas,

Your macro has a For Each loop that cycles through all the sections in the
active document.

    For Each sect In ActiveDocument.Sections
    ...
    Next

Replace the lines that begin and end this loop by the following With
statements.

    With Selection.Sections(1)
    ...
    End With

Then replace sect.PropertyOrMethod with .PropertyOrMethod and delete the
declaration of sect.

Also, in both macros, you should add the following line after the rng object
is no longer needed.

    Set rng = Nothing

Write back if you need more help.

--
Hope this helps,
Pesach Shelnitz



















































- Show quoted text -
Click to expand...

Dear Pesach,

thank you very much for your quick help. I was wondering whether my
requirement of just the current section getting a running header (the
setting "unlink from previous" has already been set for all sections)
could still be fullfiled using the range object?

Regards, Andreas
 
P

Pesach Shelnitz

Hi Andreas,

To ensure that the headers for the section where the cursor resides are not
linked to the headers for the previous section, you can add the following
lines at the beginning of the With statement that I described in my previous
response. These lines are not related to your range object.

..Headers(wdHeaderFooterPrimary).LinkToPrevious = False
..Headers(wdHeaderFooterFirstPage).LinkToPrevious = False
..Headers(wdHeaderFooterEvenPages).LinkToPrevious = False
 
A

andreas-hermle

Hi Andreas,

To ensure that the headers for the section where the cursor resides are not
linked to the headers for the previous section, you can add the following
lines at the beginning of the With statement that I described in my previous
response. These lines are not related to your range object.

.Headers(wdHeaderFooterPrimary).LinkToPrevious = False
.Headers(wdHeaderFooterFirstPage).LinkToPrevious = False
.Headers(wdHeaderFooterEvenPages).LinkToPrevious = False

--
Hope this helps,
Pesach Shelnitz








- Show quoted text -
Click to expand...

HI Peasach,

I tried to incorporate the changes, but to no avail. Could you please
help me to rewrite my code.

Thank you very much in advance. Regards, Andreas
 
P

Pesach Shelnitz

Hi Andreas,

The following macro is the result of the changes that I described, an
additional change that you requested in opening message, and the insertion of
some line breaks. I did not touch the code that generates the field codes in
the headers, so if the result is not exactly what you want, you will have to
describe the field codes that you are trying to create.

Sub a1()
' Set_Running_Headers_Current_Sect()

Dim rng As Range

If MsgBox("This macro inserts a running header for section " & _
Selection.Sections(1).Index & "." & vbCrLf & _
"Would you like to continue?", vbYesNo + vbInformation, _
"Alternating headers for main sections (e.g. 1 Implementation, 1.1
Analysis)") _
= vbNo Then
Exit Sub
Else

With Selection.Sections(1)
..Headers(wdHeaderFooterPrimary).LinkToPrevious = False
..Headers(wdHeaderFooterFirstPage).LinkToPrevious = False
..Headers(wdHeaderFooterEvenPages).LinkToPrevious = False

'Different odd- and even-page and first page headers for the whole
'Document
..PageSetup.OddAndEvenPagesHeaderFooter = True
..PageSetup.DifferentFirstPageHeaderFooter = True

Set rng = .Range
'Get the start of the section
rng.Collapse wdCollapseStart

If rng.Information(wdActiveEndAdjustedPageNumber) Mod 2 = 1 Then
'MOD gets the remainder after dividing by 2
'If it's 0, then it's an even page number
'If the first first page header starts on an even page number the
'headers are set as follows

'DO FIRST PAGE HEADERS
Set rng = .Headers(wdHeaderFooterFirstPage).Range
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:="STYLEREF 1 \n "
rng.Collapse wdCollapseEnd
rng.Text = " "
rng.Collapse wdCollapseEnd
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
"PAGE \* Arabic "
rng.Text = vbTab
rng.Collapse wdCollapseStart
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
" STYLEREF 1 "


'DO EVEN PAGE HEADERS
Set rng = .Headers(wdHeaderFooterEvenPages).Range
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:="STYLEREF 1 \n "
rng.Collapse wdCollapseEnd
rng.Text = " "
'Alternatively spaces can be replaced with a tab stop
'rng.Text = vbTab
rng.Collapse wdCollapseEnd
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
"PAGE \* Arabic "
'rng.Text = vbTab
'rng.Text = "Seite "
rng.Collapse wdCollapseStart
rng.Text = vbTab
rng.Collapse wdCollapseStart
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
" STYLEREF 1 "

ActiveDocument.UndoClear

'DO ODD PAGE HEADERS
..Headers(wdHeaderFooterPrimary).PageNumbers.NumberStyle = _
wdPageNumberStyleArabic
..Headers(wdHeaderFooterPrimary).PageNumbers.IncludeChapterNumber _
= False
Set rng = .Headers(wdHeaderFooterPrimary).Range
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
"STYLEREF 2 \n "
rng.Collapse wdCollapseEnd
rng.Text = " "
rng.Collapse wdCollapseEnd
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
"PAGE \* Arabic "
rng.Text = vbTab
'rng.Text = " "
rng.Collapse wdCollapseStart
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
" STYLEREF 2 "


Else

'DO FIRST PAGE HEADERS
Set rng = .Headers(wdHeaderFooterFirstPage).Range
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
"STYLEREF 2 \n "
rng.Collapse wdCollapseEnd
rng.Text = vbTab
rng.Collapse wdCollapseEnd
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
"PAGE \* Arabic "
rng.Text = " "
rng.Collapse wdCollapseStart
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
" STYLEREF 2 "

'DO EVEN PAGE HEADERS
Set rng = .Headers(wdHeaderFooterEvenPages).Range
..Headers(wdHeaderFooterEvenPages).PageNumbers.NumberStyle = _
wdPageNumberStyleArabic
..Headers(wdHeaderFooterEvenPages).PageNumbers.IncludeChapterNumber _
= False
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
"STYLEREF 2 \n "
rng.Collapse wdCollapseEnd
rng.Text = " "
rng.Collapse wdCollapseEnd
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
"PAGE \* Arabic "
rng.Text = vbTab
'rng.Text = " "
rng.Collapse wdCollapseStart
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
" STYLEREF 2 "

ActiveDocument.UndoClear

'DO ODD PAGE HEADERS
..Headers(wdHeaderFooterPrimary).PageNumbers.NumberStyle = _
wdPageNumberStyleArabic
..Headers(wdHeaderFooterPrimary).PageNumbers.IncludeChapterNumber = _
False
Set rng = .Headers(wdHeaderFooterPrimary).Range
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:="STYLEREF 1 \n"
rng.Collapse wdCollapseEnd
rng.Text = " "
rng.Text = vbTab
rng.Collapse wdCollapseEnd
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
"PAGE \* Arabic "
rng.Text = vbTab
rng.Collapse wdCollapseStart
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
" STYLEREF 1 "

End If

End With
End If

Application.ScreenUpdating = True
Set rng = Nothing

End Sub
 
A

andreas-hermle

Hi Andreas,

The following macro is the result of the changes that I described, an
additional change that you requested in opening message, and the insertion of
some line breaks. I did not touch the code that generates the field codesin
the headers, so if the result is not exactly what you want, you will haveto
describe the field codes that you are trying to create.

Sub a1()
' Set_Running_Headers_Current_Sect()

Dim rng As Range

If MsgBox("This macro inserts a running header for section " & _
Selection.Sections(1).Index & "." & vbCrLf & _
"Would you like to continue?", vbYesNo + vbInformation, _
"Alternating headers for main sections (e.g. 1 Implementation, 1.1
Analysis)") _
= vbNo Then
Exit Sub
Else

With Selection.Sections(1)
.Headers(wdHeaderFooterPrimary).LinkToPrevious = False
.Headers(wdHeaderFooterFirstPage).LinkToPrevious = False
.Headers(wdHeaderFooterEvenPages).LinkToPrevious = False

'Different odd- and even-page and first page headers for the whole
'Document
.PageSetup.OddAndEvenPagesHeaderFooter = True
.PageSetup.DifferentFirstPageHeaderFooter = True

Set rng = .Range
'Get the start of the section
rng.Collapse wdCollapseStart

If rng.Information(wdActiveEndAdjustedPageNumber) Mod 2 = 1 Then
'MOD gets the remainder after dividing by 2
'If it's 0, then it's an even page number
'If the first first page header starts on an even page number the
'headers are set as follows

'DO FIRST PAGE HEADERS
Set rng = .Headers(wdHeaderFooterFirstPage).Range
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:="STYLEREF 1 \n "
rng.Collapse wdCollapseEnd
rng.Text = " "
rng.Collapse wdCollapseEnd
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
"PAGE \* Arabic "
rng.Text = vbTab
rng.Collapse wdCollapseStart
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
" STYLEREF 1 "

'DO EVEN PAGE HEADERS
Set rng = .Headers(wdHeaderFooterEvenPages).Range
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:="STYLEREF 1 \n "
rng.Collapse wdCollapseEnd
rng.Text = " "
'Alternatively spaces can be replaced with a tab stop
'rng.Text = vbTab
rng.Collapse wdCollapseEnd
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
"PAGE \* Arabic "
'rng.Text = vbTab
'rng.Text = "Seite "
rng.Collapse wdCollapseStart
rng.Text = vbTab
rng.Collapse wdCollapseStart
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
" STYLEREF 1 "

ActiveDocument.UndoClear

'DO ODD PAGE HEADERS
.Headers(wdHeaderFooterPrimary).PageNumbers.NumberStyle = _
wdPageNumberStyleArabic
.Headers(wdHeaderFooterPrimary).PageNumbers.IncludeChapterNumber _
= False
Set rng = .Headers(wdHeaderFooterPrimary).Range
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
"STYLEREF 2 \n "
rng.Collapse wdCollapseEnd
rng.Text = " "
rng.Collapse wdCollapseEnd
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
"PAGE \* Arabic "
rng.Text = vbTab
'rng.Text = " "
rng.Collapse wdCollapseStart
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
" STYLEREF 2 "

Else

'DO FIRST PAGE HEADERS
Set rng = .Headers(wdHeaderFooterFirstPage).Range
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
"STYLEREF 2 \n "
rng.Collapse wdCollapseEnd
rng.Text = vbTab
rng.Collapse wdCollapseEnd
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
"PAGE \* Arabic "
rng.Text = " "
rng.Collapse wdCollapseStart
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
" STYLEREF 2 "

'DO EVEN PAGE HEADERS
Set rng = .Headers(wdHeaderFooterEvenPages).Range
.Headers(wdHeaderFooterEvenPages).PageNumbers.NumberStyle = _
wdPageNumberStyleArabic
.Headers(wdHeaderFooterEvenPages).PageNumbers.IncludeChapterNumber _
= False
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
"STYLEREF 2 \n "
rng.Collapse wdCollapseEnd
rng.Text = " "
rng.Collapse wdCollapseEnd
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
"PAGE \* Arabic "
rng.Text = vbTab
'rng.Text = " "
rng.Collapse wdCollapseStart
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
" STYLEREF 2 "

ActiveDocument.UndoClear

'DO ODD PAGE HEADERS
.Headers(wdHeaderFooterPrimary).PageNumbers.NumberStyle = _
wdPageNumberStyleArabic
.Headers(wdHeaderFooterPrimary).PageNumbers.IncludeChapterNumber = _
False
Set rng = .Headers(wdHeaderFooterPrimary).Range
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:="STYLEREF 1 \n"
rng.Collapse wdCollapseEnd
rng.Text = " "
rng.Text = vbTab
rng.Collapse wdCollapseEnd
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
"PAGE \* Arabic "
rng.Text = vbTab
rng.Collapse wdCollapseStart
rng.Fields.Add rng, Type:=wdFieldEmpty, Text:= _
" STYLEREF 1 "

End If

End With
End If

Application.ScreenUpdating = True
Set rng = Nothing

End Sub

--
Hope this helps,
Pesach Shelnitz





...

read more »- Hide quoted text -

- Show quoted text -
Click to expand...

Hi Pesach,

that is what I was after. Thank you very much for your professional
help. I really appreciate it. Regards, Andreas
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Finding sections automatically that only contain heading 1 level 5
Setting up running headers in a document by using STYLEREF FIELDS 2
Creating a master document from code 0
Inserting a Page Number in a Table in a Header 6
Copy just the page field into the clipboard from a header 5
Running headers with a logo 5
Help please - Type Mismatch error when selecting a customized footerfrom list 1
How to create two page-numbering in one document? 4

Top