View Single Post
 
Old 02-16-2022, 10:33 PM
kenny84 kenny84 is offline Windows 10 Office 2016
Novice
 
Join Date: Jan 2022
Posts: 6
kenny84 is on a distinguished road
Default

Hi Guessed,

Thanks for the guidance. I tried first one which change all heading it's work.
Second choice doesn't work for my files and dont have any message error when running the code. Would like to ask about your comment regarding to my code as below:

Sub UpdateDocumentHeaders()

Application.ScreenUpdating = False

Dim strFolder As String, strFile As String
Dim wdDocTgt As Document, wdDocSrc As Document
Dim Sctn As Section, HdFt As HeaderFooter


strFolder = GetFolder

If strFolder = "" Then Exit Sub

Set wdDocSrc = ActiveDocument

strFile = Dir(strFolder & "\*.doc", vbNormal)

While strFile <> ""


If strFolder & "" & strFile <> wdDocSrc.FullName Then
Set wdDocTgt = Documents.Open(FileName:=strFolder & "" & strFile, _
AddToRecentFiles:=False, Visible:=False)

With wdDocTgt

For Each Sctn In .Sections
'For Headers
For Each HdFt In Sctn.Headers
With HdFt
If .Exists Then
If Sctn.Index = 1 Then
.Range.FormattedText = _
wdDocSrc.Sections.First.Headers(HdFt.Index).Range. FormattedText
.Range.Characters.Last = vbNullString
ElseIf .LinkToPrevious = False Then
.Range.FormattedText = _
wdDocSrc.Sections.First.Headers(HdFt.Index).Range. FormattedText
.Range.Characters.Last = vbNullString
End If
End If
End With
Next



'For footers
For Each HdFt In Sctn.Footers
With HdFt
If .Exists Then
If Sctn.Index = 1 Then
.Range.FormattedText = _
wdDocSrc.Sections.First.Footers(HdFt.Index).Range. FormattedText
.Range.Characters.Last = vbNullString
ElseIf .LinkToPrevious = False Then
.Range.FormattedText = _
wdDocSrc.Sections.First.Footers(HdFt.Index).Range. FormattedText
.Range.Characters.Last = vbNullString
End If
End If
End With
Next

'For Heading 1 start at page 3

wdDocTgt.Range.GoTo(What:=wdGoToHeading, Which:=wdGoToFirst).ParagraphFormat.PageBreakBefor e = True

wdDocTgt.PageSetup.FooterDistance = InchesToPoints(0.6)
wdDocTgt.PageSetup.HeaderDistance = InchesToPoints(0.8)

Next



.Close SaveChanges:=True
End With


End If



strFile = Dir()
Wend
Set wdDocSrc = Nothing: Set wdDocTgt = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder( 0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function


Thanks!
Reply With Quote