I have a macro that jumps to the next occurrence of red text in a document.
It works fine until it gets to a paragraph that is all red (including the paragraph mark). It then won't move forward in the document until I move the cursor forward and try again.
I've also noticed that when the cursor is within the paragraph, if I run the macro, only the text from the cursor to the end of the paragraph is highlighted.
I suspect I need to use some form of 'collapse'? Can anyone advise?
Here's the code:
Sub Find_Red_Text()
With ActiveDocument.ActiveWindow
.ActivePane.View.SeekView = wdSeekMainDocument
Selection.Find.ClearFormatting
Selection.Find.Font.Color = wdColorRed
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
End With
End Sub
Related
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 a vba code in ms word that performs a find operation.
It finds a line with specific color. goes to the begining of that line paste from clipboard go to end of the line.
Selection.Find.ClearFormatting
Selection.Find.Font.Color = wdColorDarkRed
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.HomeKey Unit:=wdLine
Selection.PasteAndFormat (wdFormatOriginalFormatting)
I dont know much coding. just want to perform this find operation until all the lines are found and there is nothing left. Maybe an if or while loop?
Copy whatever it is you want to replicate to the clipboard, then use an ordinary Find/Replace, where:
Find = your font colour
Replace = ^c^&
and choose Replace All.
No code required, though you could record it as a macro. No looping required, either.
I want to have a VBA script perform a find / replace in a selection and then assign the macro to a button on the Quick Access ToolBar, to save having to click through the usual Find/Replace procedure.
I recorded a macro while doing this and this is what I get:
Sub FindReplace()
'
' FindReplace Macro
'
'
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^p"
.Replacement.Text = " "
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
But when I run this macro on a selection to change paragraph marks into spaces it continues on to change the whole document, not just the selection.
I'm no stranger to VBA but I can't see how to fix it so it stops when the selection is done.
You are going to need to use
.Wrap = wdFindStop
Instead of
.Wrap = wdFindAsk
I am looking to create a macro that allows me to delete a specific amount of text until it finds an open paragraph. For example:
gateways (...)
ABC
DEF
GHJ
IKL
Other
I want to delete by searching the word "gateways" and then delete all text until it finds the line before "Other". The problem is that the amount of text until "other" is variable from document to document, and I cannot find a macro that allows me to do that wothout errors.
To delete the text Gateway down to the empty line, leaving only Other
Public Sub DeleteFromTextToEmptyLine()
Selection.Find.ClearFormatting
With Selection.Find
.Text = "gateways"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
'find text
If Selection.Find.Execute() Then
'Selection.Collapse wdCollapseEnd 'remove comment to leave the word gateway intact
'Turn on Extended select mode
Selection.ExtendMode = True
'find two paragraph marks together, i.e. empty line
With Selection.Find
.Text = "^p^p"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
'if found, delete the selection
If Selection.Find.Execute() Then Selection.Delete
End If
End Sub
If you want to leave the word gateway, remove the comment from the indicated line
I make a several page word document every week. I copy text from a PDF and paste it into a word document, I then format the text that I pasted.
This takes a long time and i would like to automate it.
I need a macro or some code to select specific text, then make that text bold. The specific text i need to bold is what i call a scrap code.
There are 60 different codes. For example "FIPS", or "LILL".
Something like this:
Sub A()
'
' a Macro
'
'
Dim A(3) As String
A(1) = "code1"
A(2) = "code2"
A(3) = "code3"
For i = 1 To 3
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Replacement.Font.Bold = True
.Execute FindText:=A(i), ReplaceWith:=A(i), Format:=True, _
Replace:=wdReplaceAll
End With
Next i
End Sub
HTH!
Edit
To switch dollar amounts to bold
Sub a()
'
' a Macro
'
'
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Font.Bold = True
With Selection.Find
.Text = "$([0-9.,]{1,})"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
I would suggest recording a macro.
Then do all the modifications and formatting.
Finally, look at the code of the macro and see how it did it.
The one thing you need to figure out is how you logically want to locate the text you want to bold.
Is it a specific line? Is it at the beginning of a known word?
Once you have that answered, you can combine it with the code of the macro and automate the task.