My goal is to highlight text from one open parenthesis to the next open parenthesis, if there is no closed parenthesis between them.
Sub HighlightNestedParentheses()
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Highlight = True
Options.DefaultHighlightColorIndex = wdGray50
With Selection.Find
.Text = "\([!\)]#\("
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
The macro above works when the Word file contains the following text:
text (text (text
However, there is an infinite loop when the document contains a single open parenthesis:
text (text
I prefer to not highlight any text in this second case.
Try:
Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "\(*\)"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
End With
Do While .Find.Execute
With .Duplicate
Set Rng = .Characters.Last
Do While InStr(2, .Text, "(", vbTextCompare) > 0
.MoveEndUntil ")", wdForward
.End = .End + 1
.Start = .Start + 1
.MoveStartUntil "(", wdForward
Set Rng = .Characters.Last
Loop
End With
.End = Rng.End
.HighlightColorIndex = wdGray50
.Collapse wdCollapseEnd
Loop
End With
Application.ScreenUpdating = True
End Sub
For your revised description:
Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range
With ActiveDocument.Range
Set Rng = .Duplicate
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "("
.Replacement.Text = ""
.Forward = False
.Wrap = wdFindStop
.Format = False
.MatchWildcards = False
End With
Do While .Find.Execute
Rng.Start = .Start + 1
With Rng
If InStr(.Text, ")") = 0 Then
.HighlightColorIndex = wdBrightGreen
Else
.MoveEndUntil ")", wdBackward
If InStr(.Text, "(") = 0 Then
.MoveEndUntil "(", wdBackward
.HighlightColorIndex = wdBrightGreen
End If
End If
End With
.Collapse wdCollapseStart
Loop
End With
Application.ScreenUpdating = True
End Sub
Related
I refer to a code from :https://www.datanumen.com/blogs/quickly-find-delete-paragraphs-containing-specific-texts-word-document/
However, I can only delete the heading rather than the whole paragraph(heading + content). I've tried several methods but it still not work...please help me with this, thanks!
Sub DeleteParagraphsContainingSpecificTexts()
Dim strFindTexts As String
Dim strButtonValue As String
Dim nSplitItem As Long
Dim objDoc As Document
strFindTexts = InputBox("Enter texts to be found here, and use commas to separate them: ", "Texts to be found")
nSplitItem = UBound(Split(strFindTexts, ","))
With Selection
.HomeKey Unit:=wdStory
' Find the entered texts one by one.
For nSplitItem = 0 To nSplitItem
' Find text in Heading1
With Selection.Find
.ClearFormatting
.Text = Split(strFindTexts, ",")(nSplitItem)
.Style = wdStyleHeading1
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchWholeWord = False
.MatchCase = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchAllWordForms = False
.Execute
End With
Do While .Find.Found = True
' Expand the selection to the entire paragraph.
Selection.Expand Unit:=wdParagraph
strButtonValue = MsgBox("Are you sure to delete the paragraph?", vbYesNo)
If strButtonValue = vbYes Then
Selection.Delete
End If
.Collapse wdCollapseEnd
.Find.Execute
Loop
' Find text in Heading2
With Selection.Find
.ClearFormatting
.Text = Split(strFindTexts, ",")(nSplitItem)
.Style = wdStyleHeading2
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchWholeWord = False
.MatchCase = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchAllWordForms = False
.Execute
End With
Do While .Find.Found = True
' Expand the selection to the entire paragraph.
Selection.Expand Unit:=wdParagraph
strButtonValue = MsgBox("Are you sure to delete the paragraph?", vbYesNo)
If strButtonValue = vbYes Then
Selection.Delete
End If
.Collapse wdCollapseEnd
.Find.Execute
Loop
' Find text in Heading3
With Selection.Find
.ClearFormatting
.Text = Split(strFindTexts, ",")(nSplitItem)
.Style = wdStyleHeading3
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchWholeWord = False
.MatchCase = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchAllWordForms = False
.Execute
End With
Do While .Find.Found = True
' Expand the selection to the entire paragraph.
Selection.Expand Unit:=wdParagraph
strButtonValue = MsgBox("Are you sure to delete the paragraph?", vbYesNo)
If strButtonValue = vbYes Then
Selection.Delete
End If
.Collapse wdCollapseEnd
.Find.Execute
Loop
Next
End With
MsgBox ("Word has finished finding all entered texts.")
Set objDoc = Nothing
End Sub
The problem isn't the code, it is your understanding of what a paragraph is. In your example each line of text is a paragraph.
From your description what you are trying to do is delete blocks of content under a heading containing a keyword, or in Word terminology "a Heading Level". The following code should work for you:
Sub DeleteParagraphsContainingSpecificTexts()
Dim strFindTexts As String
Dim strButtonValue As String
Dim nSplitItem As Long
Dim objDoc As Document
strFindTexts = InputBox("Enter texts to be found here, and use commas to separate them: ", "Texts to be found")
nSplitItem = UBound(Split(strFindTexts, ","))
' Find the entered texts one by one.
For nSplitItem = 0 To nSplitItem
DeleteHeadingBlock Split(strFindTexts, ",")(nSplitItem), wdStyleHeading1
DeleteHeadingBlock Split(strFindTexts, ",")(nSplitItem), wdStyleHeading2
DeleteHeadingBlock Split(strFindTexts, ",")(nSplitItem), wdStyleHeading3
Next
End Sub
Public Sub DeleteHeadingBlock(ByVal headingText As String, headingStyle As WdBuiltinStyle)
Dim hdgBlock As Range
With ActiveDocument.Content
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = headingText
.Style = headingStyle
.Replacement.Text = ""
.Forward = True
.Format = True
.Wrap = wdFindStop
End With
Do While .Find.Execute
Set hdgBlock = .GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
hdgBlock.Delete
Loop
End With
End Sub
I have a Word macro that does hundreds of find and replace operations, but currently it applies the operations to the entire document. I need it to only apply to text between "Abstract" (bold, match case) and "References" (bold, match case).
The current code applies changes to the whole document, and then at the end of the macro, it retrospectively rejects any changes to the References with the following code:
With Selection.Find
.ClearFormatting
.Font.Bold = True
.MatchCase = True
.Forward = True
.Execute FindText:="References"
If .Found = True Then
Selection.Find.Execute
Selection.Collapse wdCollapseStart
Dim r1 As Range
Set r1 = Selection.Range
Selection.Find.Text = "DummyText"
Selection.WholeStory
Selection.Collapse wdCollapseEnd
Dim r2 As Range
Set r2 = ActiveDocument.Range(r1.start, Selection.start)
r2.Select
If Selection.Range.Revisions.Count >= 1 Then _
Selection.Range.Revisions.RejectAll
End If
End With
This selects the text between "References" in bold and "DummyText", which is just some text that's guaranteed not to be found so it selects to the end of the document, and then rejects any changes within that selection.
I've tried adapting this and putting it at the start of the macro so that all the find and replace operations only apply to the selection between the Abstract and the References like this:
Selection.Find.ClearFormatting
With Selection.Find
.Text = "Abstract"
.Forward = True
.Wrap = wdFindContinue
.Format = True
.Font.Bold = True
.MatchCase = True
.MatchWholeWord = True
End With
Selection.Find.Execute
Selection.Collapse wdCollapseStart
Dim r1 As Range
Set r1 = Selection.Range
Selection.Find.Text = "References"
Dim r2 As Range
Set r2 = ActiveDocument.Range(r1.start, Selection.start)
r2.Select
' Move cursor to start, turn on tracked changes
Selection.HomeKey Unit:=wdStory
ActiveDocument.TrackRevisions = True
With ActiveWindow.View.RevisionsFilter
.markup = wdRevisionsMarkupSimple
.View = wdRevisionsViewFinal
End With
' start replacements (these go on for ages, two examples here)
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "Also "
.Replacement.Text = "Additionally, "
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "Therefore "
.Replacement.Text = "Therefore, "
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
' and so on...
Other threads I've read seem to suggest
.Wrap = wdFindStop
in the replace fields would do what I want, but that doesn't work.
Can anybody help? Cheers.
For example:
Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "Abstract"
.Font.Bold = True
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
End With
Do While .Find.Execute
Set Rng = .Duplicate
With .Duplicate
.End = ActiveDocument.Range.End
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "References"
.Font.Bold = True
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
.Execute
End With
If .Find.Found = True Then
Rng.End = .Duplicate.End
Rng.Revisions.RejectAll
End If
End With
Loop
End With
Application.ScreenUpdating = True
End Sub
The above code accommodates multiple 'Abstract' and 'References' blocks, if needed.
You need to use multiple ranges. Once you have established the range to search then if you find something, the first thing you must do is make sure what you found is within the range. The example code below does that.
Sub FindInRange()
Dim rng As Word.Range, rStart As Long, rEnd As Long
Dim iRng As Word.Range
Set rng = ActiveDocument.Content
With rng.Find
.ClearFormatting
.Format = True
.Forward = True
.Font.Bold = True
.MatchCase = True
.MatchWholeWord = True
.Text = "Abstract"
.Wrap = wdFindStop
.Execute
If .found = True Then
rStart = rng.End
rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
.Text = "References"
.Execute
If .found Then
rEnd = rng.Start
End If
End If
End With
If rStart > 0 And rEnd > 0 Then
Set iRng = rng
iRng.Start = rStart
iRng.End = rEnd
Else
Exit Sub
End If
Set rng = iRng
With rng.Find
.ClearFormatting
.Format = True
.Forward = True
.Font.Bold = True
.MatchCase = True
.MatchWholeWord = True
.Text = "Something"
.Wrap = wdFindStop
.Execute
If .found = True And rng.InRange(iRng) Then
'do something
End If
End With
End Sub
Thanks in advance for any reply.
I am working on presentation of some reports. The periodical reports are imported from a different software into Word template. For all tables and for each row I would like to change the color of the negative numbers in column 14 only if there is a certain text in column 3.
Unfortunately I have to use a Word template to do this. It seems that a macro is my only option so I have tried to Frankenstein something from different macros I found online:
Dim varColumn As Column
Dim clColumn As Column
Dim cCell As Variant
Set clColumn = Selection.Columns(3)
Set varColumn = Selection.Columns(14)
With clColumn
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.text = "value"
.Replacement.text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
If .Information(wdWithInTable) = True Then
Selection.MoveRight Unit:=wdCell, Count:=11
End If
If cCell < 0 Then
Selection.Font.color = wdColorRed
End If
Loop
End With
End Sub
I think the macro needs lines to repeat the search. See the two lines added before Loop.
With Selection
.HomeKey Unit:=wdStory 'Starts at the beginning, to search all tables.
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "value"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
If .Information(wdWithInTable) = True And _
.Cells(1).ColumnIndex = 3 Then 'Confirms it's in the 3rd column.
.MoveRight Unit:=wdCell, Count:=11
End If
If .Range < 0 Then
.Font.Color = wdColorRed
End If
.Collapse wdCollapseEnd 'Collapses the selection to no characters.
.Find.Execute 'Searches again from the current selection point.
Loop
End With
Try:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "-[0-9][0-9,.]{1,}"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
Do While .Find.Found = True
If .Information(wdWithInTable) = True Then
If .Cells(1).ColumnIndex = 14 Then
If Split(.Rows(1).Cells(3).Range.Text, vbCr)(0) = "specified text" Then
.Font.ColorIndex = wdRed
End If
End If
End If
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Application.ScreenUpdating = True
End Sub
If the table might have vertically-merged cells, change:
If Split(.Rows(1).Cells(3).Range.Text, vbCr)(0) = "specified text" Then
to:
If Split(.Tables(1).Cell(.Cells(1).RowIndex, 3).Range.Text, vbCr)(0) = "specified text" Then
I am using the following code to bold parts of a text string, in this case where the word 'Fish' is in brackets after the word 'Oil':
Sub ReplaceAndFormat16()
Dim sConst1 As String, sReplaceMent As String
Dim rRange As Range, rFormat As Range
sConst1 = "Fish"
sReplaceMent = "Oil (" & sConst1 & ")"
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "Oil (Fish)"
.Replacement.Text = sReplaceMent
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceOne
If .Found Then
Set rRange = Selection.Range
Set rFormat = ActiveDocument.Range(rRange.Start + 5, rRange.Start + 5 + VBA.Len(sConst1))
rFormat.Font.Bold = True
End If
End With
End Sub
This code works perfectly, but only bolds the first instance, and my documents may have up to four instances of this phrase that need to be formatted bold.
How do I amend the code so it carries on and bolds all instances in the document? I am very new to VBA, so apologies if this seems like a stupid question.
Change the line
.Execute Replace:=wdReplaceOne
to
.execute Replace:=wdReplaceAll
Edit
OK the above was a stupid response. The code below does the right thing
Sub ReplaceAndFormat16()
Const myFindStr As String = "Oil (Fish)"
Dim myFindRange As Word.Range
Set myFindRange = ActiveDocument.StoryRanges(wdMainTextStory)
Do
With myFindRange.Find
.ClearFormatting
.Text = myFindStr
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
If .Found Then
With myFindRange
.MoveStartUntil cset:="fF"
.MoveEndUntil cset:="hH", Count:=wdBackward
.Font.Bold = True
.Collapse Direction:=wdCollapseEnd
End With
Else
Exit Sub
End If
End With
Loop
End Sub
How can I delete the text between <de> and the end-of-cell marker throughout my Word document?
I have reached the following code from my previous question. It appeared not to be working because my lines end with end-of-cell markers. So now I need to update this to delete the text between <de>and the end-of-cell marker.
I am unable to implement that in this code.
Sub FindTheDeleteToEndOfLine()
Dim searchTerm As String
Dim bFound As Boolean
searchTerm = "<de>"
Selection.HomeKey wdStory
'Basic Find settings
With Selection.Find
.Forward = True
.wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
'Execute the Find
Do
With Selection.Find
.Text = searchTerm
bFound = .Execute
If bFound Then
Selection.MoveEnd wdLine, 1
Selection.MoveEnd wdCharacter, -1
Selection.Delete
End If
End With
Loop While bFound
End Sub
Update: I worked out a new code less complicated, but again i am unale to define the arng.words in order to delete last part after <de>:
Dim arng As Range
Dim i As Long, j As Long
With Selection.Tables(1)
For i = 1 To .Rows.Count
For j = 1 To .Columns.Count
Set arng = .Cell(i, j).Range
arng.End = arng.End - 1
'Text = "<de>"
If Right(arng.Words, 1) = "<de>" Then
arng.Words.Last = Left(arng.Words, Len(arng.Words) - 1)
End If
Next j
Next i
End With
Try, for example:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "<de>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
Do While .Find.Found
If .Information(wdWithInTable) = True Then
.End = .Cells(1).Range.End - 1
.Delete
End If
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Application.ScreenUpdating = True
End Sub
The problem you're encountering here is due to how Word reacts to a selection inside a cell: as soon as it reaches the end of the cell it selects the entire cell.
I've modified the code (which makes it more "complicated") to take this into account. In order to deal with this, there is now a Range object in the code that stores the original "Found" point in the document. After extending the selection to the end of the line, and moving it back one character (which means the entire cell is selected), the starting point is re-set to the "found" position.
Sub FindTheDeleteToEndOfCell()
Dim searchTerm As String
Dim bFound As Boolean
Dim rngFound As Word.Range
searchTerm = "<de>"
Selection.HomeKey wdStory
'Basic Find settings
With Selection.Find
.Forward = True
.wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
'Execute the Find
Do
With Selection.Find
.Text = searchTerm
bFound = .Execute
If bFound Then
Set rngFound = Selection.Range
Selection.MoveEnd wdLine, 1
Selection.MoveEnd wdCharacter, -1
Selection.Start = rngFound.Start
Selection.Delete
End If
End With
Loop While bFound
End Sub