|
|
Thread Tools | Display Modes |
#1
|
|||
|
|||
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 |
#2
|
||||
|
||||
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".
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#3
|
|||
|
|||
Quite right, I clearly do not grasp the interaction between body text and Excel doc compared to that of Header/Footer and Excel.
|
#4
|
||||
|
||||
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#5
|
|||
|
|||
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). |
#6
|
||||
|
||||
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#7
|
|||
|
|||
I thought I had included all the macro in the text file i attached. However, I have attached the code now.
|
#8
|
||||
|
||||
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.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#9
|
|||
|
|||
Quote:
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. |
#10
|
||||
|
||||
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#11
|
|||
|
|||
Is there anything it would need to do to the code for opening templates - other than changing docx to dotx?
Last edited by macropod; 09-23-2014 at 04:36 AM. Reason: Deleted unnecessary quote of entire post replied to. |
#12
|
||||
|
||||
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.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
Tags |
find & replace, header; footer; body, vba |
|
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 |