Link to home
Start Free TrialLog in
Avatar of jperri
jperri

asked on

Macro to add same footer to 50 different documents


I have to add the same footer "Rev. 12/19/03" to approx 50 different Word documents.

Some are two pages long, but most are only one page long.  I'd like the footer to be on that last page only if possible.

Question: Is there VBA code that I could use to accomplish this task across all documents at once, without having to insert the footer into each file separately?

TIA!

Avatar of Joanne M. Orzech
Joanne M. Orzech
Flag of United States of America image

See this question:

https://www.experts-exchange.com/questions/20821221/Automatically-run-a-macro-on-a-number-of-Word-documents-in-a-folder.html

So you could want something like this (most code borrowed from above question):

Sub Test()
  Dim sPath$, sDoc$, WdDoc As Word.Document
   sPath = "C:\test\"      'Path with the docs
   sDoc = Dir(sPath & "*.doc")
 
   Do While sDoc <> ""
     Set WdDoc = Documents.Open(sPath & sDoc)
      InsertFooter
     WdDoc.Close
     sDoc = Dir
  Loop
End Sub

Sub InsertFooter()
    If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
        ActiveWindow.Panes(2).Close
    End If
    If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
        ActivePane.View.Type = wdOutlineView Then
        ActiveWindow.ActivePane.View.Type = wdPrintView
    End If
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    If Selection.HeaderFooter.IsHeader = True Then
        ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
    Else
        ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    End If
    Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "IF ", PreserveFormatting:=True
    ActiveWindow.View.ShowFieldCodes = Not ActiveWindow.View.ShowFieldCodes
    Selection.HomeKey Unit:=wdLine
    Selection.MoveRight Unit:=wdWord, Count:=2
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "PAGE ", PreserveFormatting:=True
    Selection.TypeText Text:=" = "
    Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "NUMPAGES ", PreserveFormatting:=True
    Selection.TypeText Text:=" ""Rev. 12/19/03"" """""
    Selection.EndKey Unit:=wdLine
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub
Avatar of Tommy Kinard
JOrzech,

How are you putting the "Rev. 12/19/03" on the last page only? It has been about to give me fits. I had it all working and could not get just the last page. I was starting to look into the number of pages and on the last page set the ActiveDocument.Sections.Application.Selection.HeaderFooter.LinkToPrevious = True

 Do While sDoc <> ""
     Set WdDoc = Documents.Open(sPath & sDoc)
     InsertFooter
     WdDoc.Save  '<-- added so it will not promp
     WdDoc.Close
     sDoc = Dir
  Loop

dragontooth

Yes - sorry Dragontooth - he only wanted it on last page....

Never want to give you fits :)
Avatar of mcjann
mcjann

Place all the files in a directory and run this macro against them. Additional code is available if you are tracking changes or have these files password protected. Just let me know should you need that as well.

Sub Footer()
Application.ScreenUpdating = False
Set fs = Application.FileSearch
    With fs
        .LookIn = "H:\DATA\RMs" ' this is your directory
        .SearchSubFolders = False
        .FileName = "*.doc" ' assuming these are MS Word docs
        If .Execute() > 0 Then
       
            For i = 1 To .FoundFiles.Count
                Documents.Open fs.FoundFiles(i)
                ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
                Selection.WholeStory ' to type over any text already in the footer.
                Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
                Selection.Font.Name = "News Gothic MT" ' set up the font a size as you like
                Selection.Font.Size = 8
                Selection.TypeText Text:="Rev. 12/19/03"
                ActiveDocument.Save
                ActiveDocument.Close
            Next i
        Else
            MsgBox "There were no files found."
        End If
    End With
End Sub
ASKER CERTIFIED SOLUTION
Avatar of Tommy Kinard
Tommy Kinard
Flag of United States of America image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of jperri

ASKER


I'm not sure who to award the points to!

What is the protocol for multiple answers?

First come, first served?
Avatar of jperri

ASKER


85 points for JOrzech as well on main board!
Thank you jperri.  Glad to have been of assistance.  :)
Thank You jperri, for the Points and Grade!
Glad to been able to help! :)

dragontooth