#1
|
|||
|
|||
Bulk Removal of Paragraph Mark in Header
I have a folder containing more than 500 documents, each with a header that has some text followed by 3 paragraph marks. I am looking to reduce that to only the text followed by 2 paragraph marks. Thought it would be fairly simple, but it has proved difficult for me. I have tried Chr(13) and ^p without success. Tried a bevy of different iterations. Please help.
Sub ReplaceHeaderTextInFolder2() ' Dim objDoc As Document Dim strFile As String Dim strFolder As String Dim strFindText As String Dim strReplaceText As String Dim xSelection As Selection Dim xSec As Section Dim xHeader As HeaderFooter ' Pop up input boxes for user to enter folder path, the finding and replacing texts. strFolder = InputBox("Enter folder path here:") strFile = Dir(strFolder & "" & "*.docx", vbNormal) strFindText = "^p^p^p" strReplaceText = "^p^p" ' Open each file in the folder to search and replace texts. Save and close the file after the action. While strFile <> "" Set objDoc = Documents.Open(FileName:=strFolder & "" & strFile) With objDoc For Each xSec In objDoc.Sections For Each xHeader In xSec.Headers xHeader.Range.Select Set xSelection = objDoc.Application.Selection With xSelection .HomeKey Unit:=wdStory With xSelection.Find '.Text = strFindText '.Replacement.Text = strReplaceText .Text = strFindText .Replacement.Text = strReplaceText .Forward = True .Wrap = wdFindContinue '.Wrap = wdFindStop .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With xSelection.Find.Execute Replace:=wdReplaceAll End With Next xHeader Next xSec objDoc.Save objDoc.Close strFile = Dir() End With Wend End Sub |
#2
|
||||
|
||||
Having a macro create a selection in a header is iffy at best (and if you ever actually need it, a better way is ActiveWindow.View.SeekView). Here, though, you're better off replacing your entire second loop with just this:
Code:
For Each xHeader In xSec.Headers xHeader.Range.Find.Execute FindText:="^p^p^p", ReplaceWith:="^p^p", Replace:=wdReplaceAll Next xHeader |
#3
|
||||
|
||||
Quote:
The following macro will process all Headers in all Sections of all Documents in both the chosen folder and its sub-folders. Code:
Option Explicit Dim FSO As Object, oFolder As Object, StrFolds As String, wdDocSrc As Document, wdDocTgt As Document Sub Main() Application.ScreenUpdating = False Dim TopLevelFolder As String, TheFolders As Variant, aFolder As Variant, i As Long TopLevelFolder = GetFolder If TopLevelFolder = "" Then Exit Sub StrFolds = vbCr & TopLevelFolder If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject") End If Set wdDocSrc = ActiveDocument 'Get the sub-folder structure Set TheFolders = FSO.GetFolder(TopLevelFolder).SubFolders For Each aFolder In TheFolders RecurseWriteFolderName (aFolder) Next 'Process the documents in each folder For i = 1 To UBound(Split(StrFolds, vbCr)) Call UpdateDocuments(CStr(Split(StrFolds, vbCr)(i))) Next Set wdDocSrc = Nothing: Set wdDocTgt = Nothing Application.ScreenUpdating = True End Sub Sub RecurseWriteFolderName(aFolder) Dim SubFolders As Variant, SubFolder As Variant Set SubFolders = FSO.GetFolder(aFolder).SubFolders StrFolds = StrFolds & vbCr & CStr(aFolder) On Error Resume Next For Each SubFolder In SubFolders RecurseWriteFolderName (SubFolder) Next 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 Sub UpdateDocuments(oFolder As String) Dim strInFolder As String, strFile As String, Sctn As Section, HdFt As HeaderFooter strInFolder = oFolder strFile = Dir(strInFolder & "\*.doc", vbNormal) While strFile <> "" Set wdDocTgt = Documents.Open(FileName:=strInFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False) With wdDocTgt For Each Sctn In .Sections For Each HdFt In Sctn.Headers With HdFt If .Exists Then .Range.Find.Execute FindText:="[^13]{3,}", ReplaceWith:="^p^p", MatchWildcards:=True, Replace:=wdReplaceAll End With Next Next 'Save and close the document .Close SaveChanges:=True End With strFile = Dir() Wend End Sub
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#4
|
|||
|
|||
A bevy of thanks to the two of you!
Mark and Paul thank you for your assistance in this matter.
It is greatly appreaciated. Interestingly, neither of the macros worked, initially. One, likely important facet I failed to mention (as I did not know it would make a difference) and is the likely culprit for the failure to work as desired was that the 3 paragraphs that I am attempting to replace with 2 are at the end of the header. However, both macros worked when I made substitutions (^p^p for ^p^p^p and ^p for ^p^p in Mark's code and "[^13]{2,}", ReplaceWith:="^p" in Paul's code). That is when I replaced two paragraph marks with one. However, that does not technically solve my initial problem as some of the documents may have only 2 paragraph marks in the header and if I use the adulterated code above it would mess those documents up. So what I should have asked from the beginning is: Is there a means to check for 3 paragraphs when they are the last 3 entries in a header? |
#5
|
||||
|
||||
You could just change:
FindText:="[^13]{3,}" to: FindText:="[^13]{2,}" and leave: ReplaceWith:="^p^p" alone. Alternatively, you might modify the Dim line at the top of the UpdateDocuments sub, thus: Code:
Dim strInFolder As String, strFile As String, Sctn As Section, HdFt As HeaderFooter, Rng As Range Code:
With HdFt If .Exists Then .Range.Find.Execute FindText:="[^13]{3,}", ReplaceWith:="^p^p", MatchWildcards:=True, Replace:=wdReplaceAll End With Code:
With HdFt If .Exists Then Set Rng = .Range.Characters.Last With Rng Do While .Start > HdFt.Range.Start If .Characters.First.Previous = vbCr Then .Start = .Start - 1 Else Exit Do End If Loop If .Paragraphs.Count > 2 Then .Text = vbCr & vbCr End With End If End With
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#6
|
|||
|
|||
Paul, sometimes you make me feel dumb.
Paul, the first suggestion did not seem to work...seems it does not recognize the last paragraph mark....so I made the suggested substitution.
Unfortunately, it threw an error code. Run-time error '91' Object variable or With block variable not set when I went to the debug screen the following was highlighted. Set Rng = Rng.Characters.Last The complete code is below. Option Explicit Dim FSO As Object, oFolder As Object, StrFolds As String, wdDocSrc As Document, wdDocTgt As Document Sub ReplaceParagraphsInHeader() Application.ScreenUpdating = False Dim TopLevelFolder As String, TheFolders As Variant, aFolder As Variant, i As Long TopLevelFolder = GetFolder If TopLevelFolder = "" Then Exit Sub StrFolds = vbCr & TopLevelFolder If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject") End If Set wdDocSrc = ActiveDocument 'Get the sub-folder structure Set TheFolders = FSO.GetFolder(TopLevelFolder).SubFolders For Each aFolder In TheFolders RecurseWriteFolderName (aFolder) Next 'Process the documents in each folder For i = 1 To UBound(Split(StrFolds, vbCr)) Call UpdateDocuments(CStr(Split(StrFolds, vbCr)(i))) Next Set wdDocSrc = Nothing: Set wdDocTgt = Nothing Application.ScreenUpdating = True End Sub Sub RecurseWriteFolderName(aFolder) Dim SubFolders As Variant, SubFolder As Variant Set SubFolders = FSO.GetFolder(aFolder).SubFolders StrFolds = StrFolds & vbCr & CStr(aFolder) On Error Resume Next For Each SubFolder In SubFolders RecurseWriteFolderName (SubFolder) Next 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 Sub UpdateDocuments(oFolder As String) Dim strInFolder As String, strFile As String, Sctn As Section, HdFt As HeaderFooter, Rng As Range strInFolder = oFolder strFile = Dir(strInFolder & "\*.doc", vbNormal) While strFile <> "" Set wdDocTgt = Documents.Open(FileName:=strInFolder & "" & strFile, AddToRecentFiles:=False, Visible:=False) With wdDocTgt For Each Sctn In .Sections For Each HdFt In Sctn.Headers With HdFt If .Exists Then Set Rng = Rng.Characters.Last With Rng Do While .Characters.First.Previous = vbCr .Start = .Start - 1 Loop If .Paragraphs.Count > 2 Then .Text = vbCr & vbCr End With End If End With Next Next 'Save and close the document .Close SaveChanges:=True End With strFile = Dir() Wend End Sub |
#7
|
|||
|
|||
It errors because Rng hasn’t been set to anything.
Change to: Code:
Set Rng = HdFt.Range.Characters.Last |
#8
|
|||
|
|||
Italophile thanks for joining the discussion.
I tried your suggestion and it worked a bit farther into the code. It now throws the same error on the line of: Do While .Characters.First.Previous = vbCr I tried: Do While HdFt.Characters.First.Previous = vbCr and Do While HdFt.Range.Characters.First.Previous = vbCr but neither worked. |
#9
|
||||
|
||||
See the updated code revision in post #5.
PS: When posting code, please use the code tags, indicated by the # button on the posting menu. Without them, your code loses much of whatever structure it has.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#10
|
|||
|
|||
Thank you sir for all of your assistance.
|
Thread Tools | |
Display Modes | |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
a macro to replace paragraph mark with a space applies effect on paragraph marks after the selection | drrr | Word VBA | 2 | 08-24-2021 03:05 AM |
What is this paragraph mark called | booneyrex | Word | 8 | 03-04-2021 04:15 AM |
Indention below paragraph mark... | kikola | Word VBA | 13 | 05-26-2020 06:21 AM |
Please help with header and footer removal | pwangdel | Word | 3 | 11-03-2011 06:10 AM |
Final paragraph mark | Caroline | Word | 2 | 02-22-2011 10:39 AM |