I'm trying to replace numbering (Word's 1. , 2. , etc.). In a simple string and replace search but I can't seem to find the numbers.
This is for Word 365, and I'm using the VB editor in there.
Sub ayaya()
Documents.Open FileName:=ActiveDocument.Path + "\Doc1.docm"
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "SSS"
.Replacement.Text = "PPP"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
With Selection
If .Find.Forward = True Then
.Collapse Direction:=wdCollapseStart
Else
.Collapse Direction:=wdCollapseEnd
End If
.Find.Execute Replace:=wdReplaceAll
End With
End Sub
My word document looked like this:
SSS
SSS
1. SSS
and turned to
PPP
PPP
1. PPP
but when I replace the search to any variation of
With Selection.Find
.Text = "1. SSS"
It does not find the text.
You are not finding the number associated with the paragraph text because it most likely is a ListLevelNumber and these are automatically generated by the ListFormat style. In other words, they are not part of the physical text that can be found using a Search, at least the way you currently have it setup in your code.
A separate Search would be required to find the ListParagraph Style being used and then some additional code that would manipulate the ListLevelNumber if that is what you are attempting to do.
Below is example code that determines what the ListLevelNumber is on a given paragraph and then takes some action based on what the level actually is:
Sub IsSelectionListParagraph()
Dim i As Integer
If Selection.Range.ListParagraphs.Count > 0 Then
For i = 1 To Selection.Range.ListParagraphs.Count
Select Case Selection.Range.ListParagraphs(i).Range.ListFormat.ListLevelNumber
Case Is = 1
Debug.Print Selection.Range.Text
Case Is = 2
Debug.Print Selection.Range.Text
Case Else
Debug.Print Selection.Range.Text
End Select
Next
End If
End Sub
Numbering is a ListParagraphs Object and can't be searched as if it's plain text.
Related
I am trying to create a Word macro that will:
Search for a specific word (i.e. "see")
Select the entire paragraph where that word appears
Make the whole paragraph a different style (i.e. make it all red text)
Do the same thing with a second word (i.e. "blacklist")
Select that whole paragraph and apply a different style (i.e. again, make the paragraph red text)
Copy all paragraphs with the red text style and paste them in to a new word document
Unfortunately, I'm no VBA expert and I'm trying to cobble things together from what I can find online. I have found a great example that will select to the start of the paragraph, but I can't seem to figure out how to select the entire paragraph. Any help is appreciated!
** Sorry - here is the code I currently have. It will find all instances of the word "see" and selects to the start of the paragraph, then changes the color to red... but that's as far as I've gotten, as I am stuck on trying to figure out how to get it to select to the end of the paragraph.
Sub TestOne()
'
' TestOne Macro
'
'
If MsgBox(Prompt:="Would you like to update selected paragraph styles?", Buttons:=vbYesNo + vbQuestion, _
Title:="Format MD Report") = vbNo Then
Exit Sub
End If
Application.ScreenUpdating = False
Dim i As Long
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "see"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = False
End With
Do While .Find.Execute
i = i + 1
.Start = .Paragraphs.First.Range.Start
.Font.Color = wdColorRed
.Start = .Paragraphs.First.Range.End
Loop
End With
Application.ScreenUpdating = True
MsgBox i & " instances processed."
End Sub
For example, without needing to create a second document:
Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, StrFnd As String
StrFnd = "see|blacklist"
With ActiveDocument.Range
.Font.Hidden = True
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Text = "^&"
.Font.Hidden = True
.Replacement.Font.Hidden = False
.Format = True
.Forward = True
.MatchWildcards = True
.Wrap = wdFindContinue
For i = 0 To UBound(Split(StrFnd, "|"))
.Text = "[!^13]#" & Split(StrFnd, "|")(i) & "*^13"
.Execute Replace:=wdReplaceAll
Next
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
End With
End With
Application.ScreenUpdating = True
End Sub
You could, of course, add a line of code before the final 'End With' to save the document with a new name.
To select the entire paragraph, following the line
.Start = .Paragraphs.First.Range.Start
add
.End = .Paragraphs.First.Range.End
... then to match only whole words, after
.MatchWildcards = False
add
.MatchWholeWord = True
And to run the code for multiple words you should add a parameter to your Sub eg
Sub TestOne(theWord As String)
then replace
.Text = "see"
with
.Text = theWord
And to run your code for each required word, add a Sub such as
Sub RunMe()
TestOne "see"
TestOne "blacklist"
End Sub
... optionally, move your MsgBoxes into RunMe()
I want to delete the red highlighting color from the MS Word document.
Explanation:
I made a module in MS Word documents that search/find any text highlighting with red color - a text marked with red from the tool shown in the image below. The following code is either working fine or make the MS Word stop responding. I'm not sure why it gets crashing, but I guess due to the loop that I am using. I wish there is something like: .Replacement.HighlightColorIndex = wdred ; and then .Execute Replace:=wdReplaceAll ; instead of the loop.
The VBA code that I wrote:
Sub RemoveSpecificHighlightingColor()
'
' Remove Specific Highlighting Color Macro
' This Macro go through the document and search for any Red color highlighting word and remove it
' colors code: https://learn.microsoft.com/en-us/office/vba/api/word.wdcolorindex
'
Selection.GoTo wdGoToPage, wdGoToAbsolute, 1 'Start at the top of the document
Selection.Find.ClearFormatting
Selection.Find.Highlight = True
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop 'stop at the end of the document
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
Do While (.Execute(Forward:=True) = True) = True
DoEvents 'keeps Word responsive
If Selection.Range.HighlightColorIndex = wdRed Then
Selection.Range.Delete
End If
Loop
MsgBox "Done!" ' just for testing
End With
End Sub
Some explanation about the code:
I noticed if I select at the middle of the document then run the code, the code start from the mouse selection not from the top. This is why I mentioned the first statement.
Some of the code I got from the record marco feature and from help online. The record marco detect all highlighting color not specific color.
I used Selection.Find so I selected .Wrap = wdFindStop
There is no difference if I keep or remove Format, MatchCase, MatchWholeWord, MatchWildcards, MatchSoundsLike, and MatchAllWordForms.
The main issue is the While loop or any loop that I am using. The one shown in the code check for all highlighting colors and if the color is red, then remove it, otherwise check for another.
Any help is appreciated, thanks!
The big problem with your code is that you are using the Selection object. When you select things in your code the screen has to be redrawn with each change of selection. As Selection.Find selects every match it finds that is a lot of redrawing.
In this instance you can avoid using Selection by using a Range object instead (ActiveDocument.Content is a range). When you use .Find with a range the range is redefined each time a match is found, enabling you to change the properties of that range.
Sub RemoveSpecificHighlightingColor()
Application.ScreenUpdating = False
With ActiveDocument.Content
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Highlight = True
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop 'stop at the end of the document
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Do While .Find.Execute = True
If .HighlightColorIndex = wdRed Then .Delete
Loop
End With
Application.ScreenUpdating = True
End Sub
For example:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Format = True
.Forward = True
.Highlight = True
.Wrap = wdFindStop
End With
Do While .Find.Execute
If .HighlightColorIndex = wdRed Then .Delete
'The next If ... End If block is needed if the highlighted content could be in a table
If .Information(wdWithInTable) = True Then
If .End = .Cells(1).Range.End - 1 Then
.End = .Cells(1).Range.End
.Collapse wdCollapseEnd
If .Information(wdAtEndOfRowMarker) = True Then
.End = .End + 1
End If
End If
End If
'The next line is needed if the highlighted content could include the final paragraph break
If .End = ActiveDocument.Range.End Then Exit Do
.Collapse wdCollapseEnd
Loop
End With
Application.ScreenUpdating = True
End Sub
Do note that there's a bug in Word's Find which means it won't find anything if the document consists of a single highlighted paragraph. Additionally, I haven't included code to test whether a found range spans some text as well as part of a field or spans two or more highlight colours. Consequently, neither condition will be processed.
I tried to trace the issue. What I noticed is, in some documents only (mixed of .doc and .docx file type), once I run the code, it goes through the document pages and finds and deletes the red highlighting color, that once all are replaced, the MS Word stuck. Once the MS Word got stuck, the cursor is changing rapidly, as if the screen has to be redrawn, and after a few seconds the program stops responding, and even if I wait for a while it will be stuck until I force to close the MS Word. This happened with or without red highlighting color in the document.
Explanation of the code:
The code runs each page alone by making the code start from the first page and count the number of pages. Then go through each page and select the text.
Apply the filtering code and deleting for the specific selection only, then check for a new page.
I treated the pause/stuck as a bouncing button without a pull-up or pull-down resistor i.e., once the physical button is pressed it fluctuate before it reaches a steady state.
Iteration...
The final code that I used, and It's now working for all documents is shown below:
Sub RemoveSpecificHighlightingColor()
'
' Remove Specific Highlighting Color Macro
' This Macro go through the document and search for any Red color highlighting word and remove it
' colors code: https://learn.microsoft.com/en-us/office/vba/api/word.wdcolorindex
'
Dim NumberOfAllPages As Integer
' Dim LastPageNumber As Integer
Dim PageNumber As Integer
Dim TempCounter As Integer
Dim TemoEnd As Long
Selection.Find.ClearFormatting
PageNumber = 1 'Starting page
NumberOfAllPages = ActiveDocument.ActiveWindow.Panes(1).Pages.Count
' LastPageNumber = 3 'Last page to reach - for testing
Selection.GoTo wdGoToPage, wdGoToAbsolute, PageNumber 'GoTo Page PageNumber
' Debug.Print "Start"
While PageNumber - 1 < NumberOfAllPages 'LastPageNumber
DoEvents 'keeps document responsive
Selection.GoTo wdGoToPage, wdGoToAbsolute, PageNumber 'GoTo Page PageNumber
Selection.Bookmarks("\Page").Select 'Select all the text in the page
With Selection.Find
.Highlight = True
.Text = ""
.Replacement.Text = ""
.Forward = True
Do While (.Execute(Forward:=True) = True) = True
DoEvents 'keeps document responsive
If Selection.Range.HighlightColorIndex = wdRed Then Selection.Range.Delete
' If the process is stuck at the same location for while then (50 times) it mean the page is full check from Red Highlighting Color
If ActiveWindow.Selection.End = TemoEnd Then
TempCounter = TempCounter + 1
End If
If TempCounter > 50 Then Exit Do
' Debug.Print ActiveDocument.Range.End
' Debug.Print ActiveWindow.Selection.End
TemoEnd = ActiveWindow.Selection.End
Loop
End With
TempCounter = 0 ' reset counter
' Debug.Print PageNumber
PageNumber = PageNumber + 1
Wend
End Sub
I can't tell you where your error is, but here's a working code
Sub UNHIGHCOLOR()
'HOW MANY HIGHLIGHT REGIONS ARE - store to AAAM
Selection.HomeKey wdStory
'HIG_COUNT Macro
'CTRL-FN-SHIFT TO BREAK
START:
'Selection.HomeKey wdStory
Selection.Find.ClearFormatting
Selection.Find.Highlight = True
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
If .Found Then
'MsgBox "found"
If Selection.Range.HighlightColorIndex = wdRed Then
'MsgBox "RED"
'Selection.Range.HighlightColorIndex = 0
End If
AAAM = AAAM + 1
GoTo START
Else
'MsgBox "not found"
'MsgBox AAAM & " HIGH REGIONS"
End If
End With
Selection.HomeKey wdStory
'*********************************************************
'FOR AAAM REGIONS CHANGE HIGHLIGHT RED COLORS TO NO COLOR
For X = 1 To AAAM + 1
'UNHIGHCOLOR_RED_NEXT
Selection.Find.ClearFormatting
Selection.Find.Highlight = True
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
If Selection.Range.HighlightColorIndex = wdRed Then
'MsgBox "RED"
Selection.Range.HighlightColorIndex = 0 'NO COLOR
End If
Selection.Collapse (wdCollapseEnd) 'TO FIND NEXT
Next
End Sub
I have used 90 times heading 2 in my Word document of + 1000 pages. Every heading two has numerous subheadings. The end goal is to add a separate Table Of Content (TOC) under each heading 2 which shows only the subheadings under that specific heading 2 (the text of heading 2 itself excluded, which by itself can be done by limiting the TOC to headings 3 and smaller). Searching the net made it clear that this is not as simple as it sounds. There is for instance not a checkbox in the TOC options to limit the TOC to the next section break, so using section breaks is pointless to achieve this. The only method seems to be to add separate bookmarks to all the text under each heading 2 and to limit the TOC code to the bookmark in question where the TOC is situated.
I can't figure out a way to automatically create uniquely named bookmarks (for instance numbers 1 to 90 in my case) for each of the text selections under each heading 2. So I'm willing to do this manually. But it would already be a help not to select manually all the text under each heading 2.
So here is the question: which VBA code can help me with this selection? Or can you think of a code that goes much further in achieving the end goal?
The farthest I got was to find a heading 2 add two unusual symbols "£$" in front of it, go to the next heading 2 do the same and so on. The idea here is, once that is done, I just need to search with wild cards on $*£ to select the text from the one heading 2 to the next.
But my code keeps on looping (when the end of the document is reached it starts over from the top), and since today it doesn't seem to be working at all anymore. And, admittedly, maybe the whole method is a bit crappy. I nevertheless paste the code on the bottom.
A helping hand would be much appreciated, either by improving my code, by sharing other code that selects text under the next heading 2 in the document (a macro which I then can repeat manually to continue creating manual bookmarks in the document) or by finding a much better method to achieve the end goals of separate TOCs under each heading 2 with only the headings shown under that specific heading.
Thanks a lot in advance.
Willem
Do While Selection.Find.Found = True
Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles("Kop 2")
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
If Selection.Find.Found Then
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.TypeText Text:="$£"
Selection.MoveDown Unit:=wdLine, Count:=4
End If
Loop
For example:
Sub AddHeading2TOCs()
Application.ScreenUpdating = False
Dim RngHd As Range, h As Long
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Style = wdStyleHeading2
.Format = True
.Forward = True
.Wrap = wdFindStop
End With
Do While .Find.Execute
Set RngHd = .Paragraphs(1).Range: h = h + 1
RngHd.InsertAfter vbCr
Set RngHd = RngHd.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
With RngHd
.Paragraphs(2).Range.Style = wdStyleNormal
.Start = .Paragraphs(2).Range.End
.Bookmarks.Add "BkMkHd" & h, .Duplicate
.Start = .Start - 1
.Collapse wdCollapseStart
.Fields.Add .Duplicate, wdFieldEmpty, "TOC \b BkMkHd" & h, False
End With
.Collapse wdCollapseEnd
Loop
End With
Set RngHd = Nothing
Application.ScreenUpdating = True
End Sub
I have a Find/Execute routine that looks for paragraphs in my custom style, Bullet_Type_1_Level_1, which is a custom bulleted list style, and processes the paragraphs. (It checks each paragraph in the given range to see if it terminates in a period or not, but that's not important for this question). The routine currently works fine, but I want to expand it to search for additional levels--which translates into additional styles--of my outline list and to search for a style in another list, too. Is there a compact way to have my code also look for paragraphs in Bullet_Type_1_Level_2 and numlist_Level_1 (and process them, too) while it's at it? Here's the guts of my existing code:
For Each para In RangeToCheck.Paragraphs
With Selection.Find
.Text = ""
.Style = "Bullet_Type_1_Level_1"
.Wrap = wdFindStop
.Execute
Do While .Found = True 'Look for the specified style
strSentence = Selection.Text
'Test the string using a block of code that I'm omitting, for brevity.
'Finally, depending on what happened, put or don't a period at the end of the original range.
End With
Next para
You can add another loop.
Declare i (or more meaningful variable name), and loop through that.
Dim i As Long
For Each para In RangeToCheck.Paragraphs
For i = 1 To 3
With Selection.Find
.Text = ""
Select Case i
Case 1
.Style = "Bullet_Type_1_Level_1"
Case 2
.Style = "Bullet_Type_1_Level_2"
Case 3
.Style = "numlist_Level_1"
End Select
.Wrap = wdFindStop
.Execute
Do While .Found = True 'Look for the specified style
strSentence = Selection.Text
'Test the string using a block of code that I'm omitting, for brevity.
'Finally, depending on what happened, put or don't a period at the end of the original range.
End With
Next i
Next para
Probably not the prettiest solution out there - word is not my strong point ☺.
An alternative approach that may be quicker if there are paragraphs that are none of those Styles:
Dim i As Long
For i = 1 To 3
With RangeToCheck
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Forward = True
.Format = True
.Wrap = wdFindStop
.Style = "Bullet_Type_1_Level_" & i
.Execute
End With
Do While .Find.Found = True
If .InRange(RangeToCheck) = False Then Exit Do
Select Case i
Case 1 'Do something for Bullet_Type_1_Level_1
Case 2 'Do something for Bullet_Type_1_Level_2
Case 3 'Do something for Bullet_Type_1_Level_3
End Select
If ActiveDocument.Range.End = RangeToCheck.Range.End Then Exit Do
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Next
I have a Word document which contains of lot of styles; in that I want to select particular style and make starting numbers alone bold in all the paragraph style
eg:
1. first numbers alone
23. first number alone
This is my code
Sub ParaStyle()
Selection.HomeKey wdStory
Dim i As Integer
i = 1
Do Until i = Application.ActiveDocument.Paragraphs.Count
If Selection.ParagraphFormat.Style = "heading3" Then
Selection.Find.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles("heading3")
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Font.Bold = True
With Selection.Find
.Text = "([0-9]{1,2})"
.Replacement.Text = "\1"
'.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchWildcards = True
.Execute Replace:=wdReplaceOne
End With
End If
i = i + 1
Loop
End Sub
Thanks in advance
You are running the search on the Selection, but you're not changing that selection between runs. So you just end up making the same text bold over and over again. Here's a way to do what you're doing without the Selection object:
Sub ParaStyle()
Dim objPara As Paragraph
For Each objPara In ActiveDocument.Paragraphs
If objPara.Style = "heading3" Then
With objPara.Range.find
.ClearFormatting
.Text = "([0-9]{1,2})"
.Style = ActiveDocument.Styles("heading3")
With .Replacement
.ClearFormatting
.Font.Bold = True
.Text = "\1"
End With
'.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchWildcards = True
.Execute replace:=wdReplaceOne
End With
End If
Next objPara
End Sub
I didn't change much; instead of using a Do loop we loop through all the paragraphs in the document and work on each one. You can also use your code but make sure to do ActiveDocument.Paragraphs(i).Select before running the replace. I don't recommend that, as it's best to avoid using the Selection object when you can (one good reason to avoid it is that, if you have a script that takes a while and you try to do something else in a text editor, say, you'll run the risk of contaminating your clipboard).
Do keep in mind that there's nothing here to prevent this search from finding a number in the middle of the paragraph if there's none at the beginning. I'm assuming that narrowing it down by style is enough for you, or you wouldn't be using this approach.