Created VBA to Find and Replace in Body, Header and Footer with Highlighting the replacement text

QA_Compliance_Advisor · #1 09-12-2014, 12:04 AM

With the Help of many different MVP and forums on here I have been able to find and replace from a excel doc list within the Body of a document which is automated to do every word document in a folder. Much appreciated guys.

However, I am having problems with getting the Header and Footer to actually do the same to find and replace from the excel doc.

I have attached the Code because it is so big in a txt file. it’s a bit messy, apologises in advance.

the code seems to process changes the body text but does nothing to the Header or Footer.

From: https://www.msofficeforums.com/word-...s-newpost.html

Code:

Sub UpdateDocuments()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, wdDoc As Document
Dim Sctn As Section, HdFt As HeaderFooter, Shp As Shape
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, _
    AddToRecentFiles:=False, Visible:=False)
  With wdDoc
    'Process the body
    Call Update(.Range)
    'Process textboxes etc in the body
    For Each Shp In .Shapes
      With Shp.TextFrame
        If .HasText Then
          Call Update(.TextRange)
        End If
      End With
    Next
    For Each Sctn In .Sections
      For Each HdFt In Sctn.Headers
        With HdFt
          If .LinkToPrevious = False Then
            'Process the header
            Call Update(.Range)
          End If
        End With
      Next
    Next
    .Close SaveChanges:=True
  End With
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub
 
Sub Update(Rng As Range)
With Rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "04-15-09"
  .Replacement.Text = "05-05-14"
  .Forward = True
  .Wrap = wdFindStop
  .Format = False
  .Execute Replace:=wdReplaceAll
End With
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

How would I incoroprate code inthe above wo allow find and replace from an excel Document to replace word in body, header and footer?

macropod · #2 09-14-2014, 06:24 AM

Instead of resurrecting old threads to ask questions about something you've already started a thread on, please just add a link & relevant content to your existing thread. See my mods to your last post for an idea of what to do.

As for integrating, what is the existing code you want it to be integrated into?

Your attachment in the first post already seems to have all the code you need for header/footer processing but you've evidently just dumped the header/footer code into it without any real thought as to how it relates to the rest. Hence, you're "having problems with getting the Header and Footer to actually do the same to find and replace from the excel doc".

QA_Compliance_Advisor · #3 09-15-2014, 01:55 AM

Quite right, I clearly do not grasp the interaction between body text and Excel doc compared to that of Header/Footer and Excel.

macropod · #4 09-15-2014, 02:26 AM

Try:

Code:

Sub BulkFindReplace()
Application.ScreenUpdating = False
Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String, StrWkSht As String
Dim strFolder As String, strFile As String, strDocNm As String, wdDoc As Document
Dim Rng As Range, Sctn As Section, HdFt As HeaderFooter, strFnd As String, strRep As String
Dim iDataRow As Long, i As Long, xlFList As String, xlRList As String
StrWkBkNm = "C:\Users\" & Environ("Username") & "\Documents\Projects\IMS Structure Change\Find and Replace.xlsx"
StrWkSht = "Sheet1"
If Dir(StrWkBkNm) = "" Then
  MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
  Exit Sub
End If
strFolder = GetFolder
If strFolder = "" Then
  MsgBox "No document folder selected", vbExclamation
  Exit Sub
End If
If Dir(strFolder & "\*.docx", vbNormal) = "" Then
  MsgBox "No docx documents in the folder selected", vbExclamation
  Exit Sub
End If
On Error Resume Next
'Start Excel
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
  MsgBox "Can't start Excel.", vbExclamation
  Exit Sub
End If
On Error GoTo 0
With xlApp
  'Hide our Excel session
  .Visible = False
  ' The file is available, so open it.
  Set xlWkBk = .Workbooks.Open(FileName:=StrWkBkNm, ReadOnly:=True, AddToMru:=False)
  If xlWkBk Is Nothing Then
    MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
    .Quit
    Exit Sub
  End If
  ' Process the workbook.
  With xlWkBk
    'Ensure the worksheet exists
    If SheetExists(xlWkBk, StrWkSht) = True Then
      With .Worksheets(StrWkSht)
        ' Find the last-used row in column A.
        iDataRow = .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp
        ' Capture the F/R data.
        For i = 1 To iDataRow
          ' Skip over empty fields to preserve the underlying cell contents.
          If Trim(.Range("A" & i)) <> vbNullString Then
            xlFList = xlFList & "|" & Trim(.Range("A" & i))
            xlRList = xlRList & "|" & Trim(.Range("B" & i))
          End If
        Next
      End With
    Else
      MsgBox "Cannot find the designated worksheet: " & StrWkSht, vbExclamation
    End If
  .Close False
  End With
  .Quit
End With
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
'Exit if there are no data
If xlFList = "" Then Exit Sub
'Now we can start processing the documents
strFile = Dir(strFolder & "\*.docx", vbNormal)
While strFile <> ""
  If strFolder & "\" & strFile <> strDocNm Then
    Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
    With wdDoc
      'Process each word from the F/R List
      For i = 1 To UBound(Split(xlFList, "|"))
        strFnd = Split(xlFList, "|")(i)
        strRep = Split(xlRList, "|")(i)
        Call Update(.Range, strFnd, strRep)
        'Alternatively, to include footnotes, etc."
        'For Each Rng In .StoryRanges
          'Call Update(Rng, strFnd, strRep)
        'Next
        For Each Sctn In .Sections
          For Each HdFt In Sctn.Headers
            Call Update(HdFt.Range, strFnd, strRep)
          Next
          For Each HdFt In Sctn.Footers
            Call Update(HdFt.Range, strFnd, strRep)
          Next
        Next
       Next
      .Close SaveChanges:=True
    End With
  End If
  strFile = Dir()
Wend
Set wdDoc = 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
 
Function SheetExists(xlWkBk As Object, SheetName As String) As Boolean
Dim i As Long: SheetExists = False
With xlWkBk
  For i = 1 To .Sheets.Count
    If .Sheets(i).Name = SheetName Then
      SheetExists = True:   Exit For
    End If
  Next
End With
End Function
 
Sub Update(Rng As Range, strFnd As String, strRep As String)
With Rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = strFnd
  .Replacement.Text = strRep
  .Forward = True
  .Wrap = wdFindStop
  .Format = False
  .Execute Replace:=wdReplaceAll
End With
End Sub

QA_Compliance_Advisor · #5 09-17-2014, 02:20 AM

I am having issues, in the header it is only finding and replacing text in text boxes and ignoring text which is not in a text box.

Futhermore, the code seem to only change the headers (with the same problem mentioned above) of the first file in the subfolders.

any suggestions? The first page has a graphic/picture and the rest are the same to a degree were some may have section breaks to allow different information to be displayed. Apologises, only since I have strated getting to understand headers and footer and testing it in different documents I am starting to see different formats within different documents (which i was not aware at the time).

macropod · #6 09-17-2014, 02:56 AM

Your post seems to have nothing in particular to do with the code I posted, because that code:
1. does not process textboxes anywhere in the document; and
2. it doesn't look in any subfolders.
I didn't include either of those features because you didn't ask for them. The code in post #4 should give you an idea of how to incorporate the textbox processing into the code (some minor changes are needed for adaptation to header/footer textboxes). Sub-folder processing would entail a substantial re-write, so I don't propose to do that. That said, for the kind of code modifications needed to process sub-folders, see: https://www.msofficeforums.com/word-vba/16209-run-macro-multiple-docx-files.html#post47785

QA_Compliance_Advisor · #7 09-17-2014, 04:21 AM

I thought I had included all the macro in the text file i attached. However, I have attached the code now.

macropod · #8 09-17-2014, 04:52 AM

There is a whole bunch of code in that attachment that has nothing to do with what we've been discussing in this thread. Once again, it looks like you've been cobbling together sets of quite unrelated code. Evidently, the extra is from: https://www.msofficeforums.com/word-...matically.html. And nowhere in either thread have you given any indication I can see that both macros were intended to work together. Consequently, pretty much everything done in this thread has been a waste of time - a complete re-write would be required for code that would work with the process in the other thread. I don't propose to do that.

Likewise, I doubt Graham will be amused to find how much difference the project's scope really is from what he's seen so far in that other thread. That code, too, would require substantial re-working.

QA_Compliance_Advisor · #9 09-17-2014, 05:08 AM

Quote:

Originally Posted by macropod

There is a whole bunch of code in that attachment that has nothing to do with what we've been discussing in this thread.

Fair comment - I thought i was actually do ok with the graham code and incorporating it into the code, however, obviously not.

the project steamed from the https://www.msofficeforums.com/word-...xtensions.html and evolved for more and more.

As I said I thought I had included the whole code. my bad - I can only apologise.

I obviuosly have not been clear.

The project is to find & replace (with repalcement text being highlighted) from an excel doc the following actions,
(1) body of the document (including tables) (orignally discussed here https://www.msofficeforums.com/word-...xtensions.html),
(2) headers and Footers (including tables as it would appear),
(3) drop down list ( discussed here https://www.msofficeforums.com/word-...tically-2.html),
(4) replace a logo within the Header.

I have 2000 docs to change(as described above) which are in sub-folders.

macropod · #10 09-19-2014, 11:46 PM

Somewhat against my better judgment, I've revised the previous code to work with subfolders. It also incorporates the formfield processing and logic for the logo processing. Logic for the shaded table processing could also be added.

Note: This is entirely independent of Graham's addin - it's not intended to be run with that. I'm not saying there's anything wrong with Graham's code - we even collaborate at times! It's just that I have my own code libraries and I find it easier to work with what I already have than start working with someone else's code for a large project. For one thing, you'll note that I've used Subs to do things that Graham's code uses Functions for. I imagine Graham's code would need re-working too to work with your Excel F/R workbook.

Code:

Option Explicit
 
'Re-used & shared variables
Dim FSO As Object, oFolder As Object, oSubFolder As Object
Dim oFiles As Object, oItem As Object
Dim i As Long, j As Long, k As Long, l As Long
Dim xlFList As String, xlRList As String, strFnd As String, strRep As String
Dim wdDoc As Document, Rng As Range, Sctn As Section, HdFt As HeaderFooter, FmFld As FormField
Dim bChng As Boolean, bProt As Boolean, Shp As Shape, StrLogo As String
Dim StrDtTm As String, StrPwd As String, Rng As Range
  
Sub Main()
Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String, StrWkSht As String
Dim bStrt As Boolean, iDataRow As Long, bFound As Boolean
' Minimise screen flickering
Application.ScreenUpdating = False
' initialze the counters
i = 0: j = 0: k = 0
StrLogo = "C:\Users\" & Environ("Username") & "\Documents\NewLogo.png"
StrWkBkNm = "C:\Users\" & Environ("Username") & "\Documents\Projects\IMS Structure Change\Find and Replace.xlsx"
StrWkSht = "Sheet1"
If Dir(StrWkBkNm) = "" Then
  'MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
  'Exit Sub
End If
Dim StrFolder As String
' Browse for the starting folder
StrFolder = GetTopFolder
If StrFolder = "" Then
  MsgBox "No document folder selected", vbExclamation
  Exit Sub
End If
' Test whether Excel is already running.
On Error Resume Next
bStrt = False ' Flag to record if we start Excel, so we can close it later.
Set xlApp = GetObject(, "Excel.Application")
'Start Excel if it isn't running
If xlApp Is Nothing Then
  Set xlApp = CreateObject("Excel.Application")
  If xlApp Is Nothing Then
    MsgBox "Can't start Excel.", vbExclamation
    Exit Sub
  End If
  ' Record that we've started Excel.
  bStrt = True
End If
On Error GoTo 0
'Check if the workbook is open.
bFound = False
With xlApp
  'Hide our Excel session
  If bStrt = True Then .Visible = False
  For Each xlWkBk In .Workbooks
    If xlWkBk.FullName = StrWkBkNm Then ' It's open
      Set xlWkBk = xlWkBk
      bFound = True
      Exit For
    End If
  Next
  ' If not open by the current user.
  If bFound = False Then
    Set xlWkBk = .Workbooks.Open(StrWkBkNm, , True, , , , , , , , , , False)
    If xlWkBk Is Nothing Then
      MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
      If bStrt = True Then .Quit
      Exit Sub
    End If
  End If
  ' Process the workbook.
  With xlWkBk.Worksheets(StrWkSht)
    ' Find the last-used row in column A.
    iDataRow = .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp
    ' populate the F/R List.
    For k = 1 To iDataRow
      ' Skip over empty fields to preserve the underlying cell contents.
      If Trim(.Range("A" & k)) <> vbNullString Then
        xlFList = xlFList & "|" & Trim(.Range("A" & k))
        xlRList = xlRList & "|" & Trim(.Range("B" & k))
      End If
    Next
  End With
  If bFound = False Then xlWkBk.Close False
  If bStrt = True Then .Quit
End With
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
StrPwd = InputBox("What is the password for documents with forms protection?")
' Search the top-level folder
Call GetFolder(StrFolder & "\")
' Search the subfolders for more files
Call SearchSubFolders(StrFolder)
' Return control of status bar to Word
Application.StatusBar = ""
' Restore screen updating
Application.ScreenUpdating = True
MsgBox i & " of " & j & " files updated.", vbOKOnly
End Sub
  
Function GetTopFolder() As String
GetTopFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetTopFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
  
Sub SearchSubFolders(strStartPath As String)
If FSO Is Nothing Then
  Set FSO = CreateObject("scripting.filesystemobject")
End If
Set oFolder = FSO.GetFolder(strStartPath)
Set oSubFolder = oFolder.subfolders
For Each oFolder In oSubFolder
  Set oFiles = oFolder.Files
  ' Search the current folder
  Call GetFolder(oFolder.Path & "\")
  ' Call ourself to see if there are subfolders below
  SearchSubFolders oFolder.Path
Next
End Sub
  
Sub GetFolder(StrFolder As String)
Dim strFile As String
strFile = Dir(StrFolder & "*.docx")
' Process the files in the folder
While strFile <> ""
  ' Update the status bar is just to let us know where we are
  Application.StatusBar = StrFolder & strFile
  Call UpdateFile(StrFolder & strFile)
  strFile = Dir()
Wend
End Sub
  
Sub UpdateFile(strDoc As String)
StrDtTm = FileDateTime(strDoc)
bProt = False
' Open the document
Set wdDoc = Documents.Open(strDoc, AddToRecentFiles:=False, ReadOnly:=False, Format:=wdOpenFormatAuto, Visible:=False)
With wdDoc
  Select Case .ProtectionType
    Case wdNoProtection
    Case wdAllowOnlyFormFields
      bProt = True
      On Error Resume Next
      .Unprotect Password:=StrPwd
      On Error GoTo 0
      If .ProtectionType <> wdNoProtection Then GoTo NoGo
    Case Else
NoGo:
      ' Output a 'protected' file report in the document from which the macro is run.
      ThisDocument.Range.InsertAfter vbCr & strDoc & " protected. Not updated."
      .Close SaveChanges:=False
      GoTo ProtExit
  End Select
  'Process each word from the F/R List
  For k = 1 To UBound(Split(xlFList, "|"))
    strFnd = Split(xlFList, "|")(k)
    strRep = Split(xlRList, "|")(k)
    Call FndRep(.Range, strFnd, strRep)
    'Alternatively, to include footnotes, etc."
    'For Each Rng In .StoryRanges
      'Call Update(Rng, strFnd, strRep)
    'Next
    For Each Sctn In .Sections
      For Each HdFt In Sctn.Headers
        Call FndRep(HdFt.Range, strFnd, strRep)
      Next
      For Each HdFt In Sctn.Footers
        Call FndRep(HdFt.Range, strFnd, strRep)
      Next
    Next
  Next
  Call UpdateFmFlds(.Range)
  Call UpdateLogo(.Sections.First)
  If bProt = True Then .Protect Type:=wdAllowOnlyFormFields, NoReset:=True, Password:=StrPwd
  .Close SaveChanges:=True
  i = i + 1
End With
' Let Word do its housekeeping
DoEvents
' Reset the file's Date/Time stamp.
If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject")
Set oItem = FSO.GetFile(strDoc)
On Error Resume Next
If IsDate(StrDtTm) Then If oItem.DateLastModified <> StrDtTm Then oItem.DateLastModified = StrDtTm
ProtExit:
' Update the main file counter
j = j + 1
Set wdDoc = Nothing
End Sub
  
Sub FndRep(Rng As Range, strFnd As String, strRep As String)
With Rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = strFnd
  .Replacement.Text = strRep
  .Forward = True
  .Wrap = wdFindStop
  .Format = False
  .Execute Replace:=wdReplaceAll
End With
End Sub
  
Sub UpdateFmFlds(Rng As Range)
With Rng
  For Each FmFld In .FormFields
    With FmFld
      If .Type = wdFieldFormDropDown Then
        bChng = False
        If .Name = "Dropdown1" Then
          bChng = True
        Else
          For i = 1 To .DropDown.ListEntries.Count
            If .DropDown.ListEntries(i).Name = "Select Vessel" Then
              bChng = True
              Exit For
            End If
          Next
        End If
      End If
      If bChng = True Then
        .Name = "drpVessel"
        'With .DropDown.ListEntries
        '  .Clear
        '  .Add "Item 1"
        '  .Add "Item 2"
        '  .Add "Item 3"
        '  .Add "Item 4"
        'End With
        Exit For
      End If
    End With
  Next
End With
End Sub
  
Sub UpdateLogo(Sctn1 As Section)
With Sctn1
  If .Headers(wdHeaderFooterFirstPage).Exists Then
    With .Headers(wdHeaderFooterFirstPage)
      If .Shapes.Count = 1 Then
        With Shapes(1)
          Set Rng = .Anchor
          .Delete
        End With
        Set Shp = .Shapes.AddPicture(FileName:=StrLogo, LinkToFile:=False, Anchor:=Rng, Left:=0, Top:=0, Width:=100, Height:=75)
      ElseIf .Range.InlineShapes.Count = 1 Then
        With .Range.InlineShapes(1)
          Set Rng = .Range
          .Delete
        End With
        Set Shp = .Shapes.AddPicture(FileName:=StrLogo, LinkToFile:=False, Anchor:=Rng, Left:=0, Top:=0, Width:=100, Height:=75)
        Shp.ConvertToInlineShape
      End If
    End With
  Else
    With .Headers(wdHeaderFooterPrimary)
      If .Shapes.Count = 1 Then
        With Shapes(1)
          Set Rng = .Anchor
          .Delete
        End With
        Set Shp = .Shapes.AddPicture(FileName:=StrLogo, LinkToFile:=False, Anchor:=Rng, Left:=0, Top:=0, Width:=100, Height:=75)
      ElseIf .Range.InlineShapes.Count = 1 Then
        With .Range.InlineShapes(1)
          Set Rng = .Range
          .Delete
        End With
        Set Shp = .Shapes.AddPicture(FileName:=StrLogo, LinkToFile:=False, Anchor:=Rng, Left:=0, Top:=0, Width:=100, Height:=75)
        Shp.ConvertToInlineShape
      End If
    End With
  End If
End With
End Sub

I don't have anything to test with, so I can't guarantee it's bug-free at this stage.

QA_Compliance_Advisor · #11 09-23-2014, 04:14 AM

Is there anything it would need to do to the code for opening templates - other than changing docx to dotx?

macropod · #12 09-23-2014, 04:40 AM

I believe the only thing you'd need to change is from:
strFile = Dir(StrFolder & "*.docx")
to:
strFile = Dir(StrFolder & "*.dotx")
However, given that templates in Word 2007 & later are often macro-enabled, you might do better to use:
strFile = Dir(StrFolder & "*.dot")
This will open .dotx, .dotm and .dot templates.

PS: Please don't quote previous posts in your replies unless there's something specific you need to refer to - and then include only the relevant portion(s). Anything more just adds clutter.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Find & Replace in Header/Footer in 1000 files	amodiammmuneerk@glenmarkp	Word	12	03-05-2018 03:31 AM
Find & Replace in Header/Footer	PReinie	Word	6	01-22-2014 06:45 PM
Footer Find & Replace Operation?	binar	Word	1	02-05-2013 10:39 PM
Insert a header name in the text (body)	bal-007	Word	3	11-25-2011 01:08 PM
Find and replace page numbers in body of text	tollanarama	Word	3	02-13-2011 06:00 AM