Microsoft Office Forums Macro for find/replace (including headers and footers) for multiple documents

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 05-15-2014, 09:01 AM
jpb103's Avatar
jpb103 jpb103 is offline Macro for find/replace (including headers and footers) for multiple documents Windows 7 64bit Macro for find/replace (including headers and footers) for multiple documents Office 2007
Advanced Beginner
Macro for find/replace (including headers and footers) for multiple documents
 
Join Date: May 2014
Location: Thunder Bay, Ontario
Posts: 58
jpb103 is on a distinguished road
Question Macro for find/replace (including headers and footers) for multiple documents

I am currently struggling with a macro I'm putting together for performing a find/replace on a collection of (multiple) documents that includes the headers and footers (though I'm mostly just concerned with the footer).
The macro works fine on the first file, and then crashes word. The VBA code I currently have for the macro is as follows:



Code:
Public Sub FindReplaceAnywhere()
Dim rngStory As Word.Range
Dim pFindTxt As String
Dim pReplaceTxt As String
Dim lngJunk As Long
Dim oShp As Shape
Dim MyDialog As FileDialog, GetStr(1 To 100) As String '100 files is the maximum applying this code'
On Error Resume Next
Set MyDialog = Application.FileDialog(msoFileDialogFilePicker)
With MyDialog
.Filters.Clear
.Filters.Add "All WORD File ", "*.docx", 1
.AllowMultiSelect = True
i = 1
If .Show = -1 Then
For Each stiSelectedItem In .SelectedItems
GetStr(i) = stiSelectedItem
i = i + 1
Next
i = i - 1
End If
Application.ScreenUpdating = False
pFindTxt = InputBox("Enter the text that you want to find." _
, "FIND")
If pFindTxt = "" Then
MsgBox "Cancelled by User"
Exit Sub
End If
TryAgain:
pReplaceTxt = InputBox("Enter the replacement.", "REPLACE")
If pReplaceTxt = "" Then
If MsgBox("Do you just want to delete the found text?", _
vbYesNoCancel) = vbNo Then
GoTo TryAgain
ElseIf vbCancel Then
MsgBox "Cancelled by User."
Exit Sub
End If
End If
For j = 1 To i Step 1
Set Doc = Documents.Open(FileName:=GetStr(j), Visible:=True)
Windows(GetStr(j)).Activate
'Fix the skipped blank Header/Footer problem'
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
'Iterate through all story types in the current document'
For Each rngStory In ActiveDocument.StoryRanges
'Iterate through all linked stories'
Do
SearchAndReplaceInStory rngStory, pFindTxt, pReplaceTxt
On Error Resume Next
Select Case rngStory.StoryType
Case 6, 7, 8, 9, 10, 11
If rngStory.ShapeRange.Count > 0 Then
For Each oShp In rngStory.ShapeRange
If oShp.TextFrame.HasText Then
SearchAndReplaceInStory oShp.TextFrame.TextRange, _
pFindTxt, pReplaceTxt
End If
Next
End If
Case Else
'Do Nothing'
End Select
On Error GoTo 0
'Get next linked story (if any)'
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next
ActiveDocument.Save
ActiveWindow.Close
Next
Application.ScreenUpdating = True
End With
MsgBox "Complete!", vbInformation
End Sub
Public Sub SearchAndReplaceInStory(ByVal rngStory As Word.Range, _
ByVal strSearch As String, ByVal strReplace As String)
With rngStory.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = strSearch
.Replacement.Text = strReplace
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
End Sub

Last edited by jpb103; 05-15-2014 at 10:39 AM. Reason: Didn't know how to make a code box
Reply With Quote
  #2  
Old 05-15-2014, 03:32 PM
macropod's Avatar
macropod macropod is online now Macro for find/replace (including headers and footers) for multiple documents Windows 7 32bit Macro for find/replace (including headers and footers) for multiple documents Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 19,648
macropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to behold
Default

You might care to look at these threads:
https://www.msofficeforums.com/word-...ple-files.html
https://www.msofficeforums.com/word-...ocx-files.html
__________________
Cheers,
Paul Edstein
[MS MVP - Word]
Reply With Quote
  #3  
Old 05-16-2014, 04:59 AM
jpb103's Avatar
jpb103 jpb103 is offline Macro for find/replace (including headers and footers) for multiple documents Windows 7 64bit Macro for find/replace (including headers and footers) for multiple documents Office 2007
Advanced Beginner
Macro for find/replace (including headers and footers) for multiple documents
 
Join Date: May 2014
Location: Thunder Bay, Ontario
Posts: 58
jpb103 is on a distinguished road
Default

Thanks! I'll have a looksee.
Reply With Quote
Reply

Tags
find, footer, replace

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
Macro for find/replace (including headers and footers) for multiple documents Replace text in multiple documents? Roscoe Word VBA 8 07-31-2017 04:02 PM
Macro for find/replace (including headers and footers) for multiple documents How do I find/replace the same word in multiple documents? Ineedhelp! Word 3 03-04-2014 03:50 PM
Macro for find/replace (including headers and footers) for multiple documents Replace words within headers in multiple document Carchee Word VBA 14 12-19-2013 04:36 PM
Macro for find/replace (including headers and footers) for multiple documents How do I find and replace multiple items at once? redzan Word VBA 1 05-16-2013 08:25 AM
Find and replace multiple documents change style BaPW Word 0 08-14-2011 11:12 AM


All times are GMT -7. The time now is 05:42 AM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2019, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2019 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft