I have a macro that uses wildcards to find acronyms in a Word document.
I want to 'unhighlight' that acronym if it is followed by a (.
For example, my content might say "BRB (be right back)" so BRB would not be highlighted. But, LOL would be highlighted if (laughing out loud) does not immediately follow the text.
I am trying to avoid false positives. Is there way I can exclude the 'BRB' results?
With ActiveDocument.Content.Find
.ClearFormatting
.Text = "<[A-Z]{2,}>"
With .Replacement
.Text = "^&"
.ClearFormatting
.Highlight = True
End With
Try this out:
Sub HighlightAcronyms()
Dim rng As Range, r2 As Range
Set rng = ActiveDocument.Content
Set r2 = ActiveDocument.Content
With rng.Find
.ClearFormatting
.Text = "<[A-Z]{2,}>"
.Forward = True
.Wrap = wdFindStop
.MatchCase = True
.MatchWildcards = True
.Format = False
Do While .Execute
'look two characters past the found acroynm
r2.Start = rng.End + 1
r2.End = rng.End + 3
Debug.Print rng.Text, r2.Text
'highlight if r2 has a "(" otherwise clear highlight
rng.HighlightColorIndex = IIf(r2.Text Like "*(*", _
wdAuto, wdYellow)
Loop
End With
End Sub
Related
I have a transliteration function (from cyrillic to latin). I will use this function in a unviersal subroutine (with text of any lenght). This sub must to copy the source text, transliterate (from cyrillic to latin) and paste it below without any formatting changes and without using selection. The next step is reverse transliteration (again copy and paste below). There must be 3 textes in the final. I kinda know how to realize it, but i don't know what i should use instead of selection.
*
P.S. i tried use For Each word In ActiveDocument.Range.Words but it works bad with reverse transliteration (exactly that. without it, the function works perfectly in debugging)
P.P.S. sorry for mistakes in the text, i'm not a native speaker
Since you haven't posted any actual transliteration code, I'll leave you to add the cyrillic and latin character sets to the code below:
Sub Transliterate()
Application.ScreenUpdating = False
Dim p As Long, i As Long, StrLng1, StrLng2
'Insert the character codes for the cyrillic characters here
StrLng1 = Array(ChrW(&H430), ChrW(&H431), ChrW(&H432))
'Insert the corresponding latin characters here
StrLng2 = Array("a", "b", "c")
With ActiveDocument.Range
Do While .Characters.Last.Previous = vbCr
.Characters.Last.Previous.Delete
Loop
.InsertAfter vbCr
'Duplicate Content
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Wrap = wdFindContinue
.MatchWildcards = True
.Text = "^13"
.Replacement.Text = "^l"
.Execute Replace:=wdReplaceAll
.Font.Bold = True
.Text = "[!^l]#^l"
.Replacement.Text = "^p^&"
.Execute Replace:=wdReplaceAll
.ClearFormatting
.Text = "^l^13"
.Replacement.Text = "^p"
.Execute Replace:=wdReplaceAll
.Execute Replace:=wdReplaceAll
.Text = "[!^13]#^13"
.Replacement.Text = "^&^&^p"
.Execute Replace:=wdReplaceAll
End With
.Characters.Last.Previous.Delete
.Characters.First.Delete
'Loop through duplicated paragraphs
For p = .Paragraphs.Count - 1 To 2 Step -3
With .Paragraphs(p).Range
.Font.Italic = True
'Transliterate paragraph
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Wrap = wdFindStop
.MatchWildcards = False
.MatchCase = True
.Font.Bold = False
For i = 0 To UBound(StrLng1)
.Text = StrLng1(i)
.Replacement.Text = StrLng2(i)
.Execute Replace:=wdReplaceAll
Next
End With
'Duplicate translated paragraph
.Characters.Last.Next.FormattedText = .FormattedText
End With
Next
.Characters.Last.Previous.Delete
'Loop through duplicated paragraphs
For p = .Paragraphs.Count To 3 Step -3
With .Paragraphs(p).Range
.Font.Underline = wdUnderlineSingle
'Reverse Transliterate paragraph
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Wrap = wdFindStop
.MatchWildcards = False
.Font.Bold = False
.MatchCase = True
For i = 0 To UBound(StrLng1)
.Text = StrLng2(i)
.Replacement.Text = StrLng1(i)
.Execute Replace:=wdReplaceAll
Next
End With
End With
Next
End With
Application.ScreenUpdating = True
End Sub
this is my first post here!
I am new to Microsoft VBA, but I need to write some macros to quickly make the same changes to 200+ documents. I took the Udemy course on Word VBA but I am stuck trying to figure out how to address the following issues:
I need to select all content from beginning of doc up until the first occurrence of the string "following:" including the string itself - the issue is that for each doc, this string will always be in a different position and the portion I want to delete will vary in length. The only guarantee is that it will always be on the first page.
I need to do the same thing for the end of the document - I need to delete all content following the string "Affirmative Defenses" including the string itself - again, this will always be in a different position and will not always be on the last page (unlike issue number 1)
I have written many variations by reading other questions/solutions with no luck. Below is my current version but it does not work.
Sub DeleteBegin()
Dim findRng As Range
Set findRng = ActiveDocument.Range
Dim endPara As Long
With findRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "following."
.Replacement.Text = ""
.Wrap = wdFindStop
.MatchWholeWord = True
.Forward = True
.Execute
If .Found = True Then
endPara = GetParaNum(findRng)
findRng.Start = 0
findRng.End = endPara
End If
Dim capRng As Range
Set capRng = ActiveDocument.Range
capRng.SetRange Start:=0, End:=endPara
capRng.Select
Selection.Delete
End With
End Sub
Function GetParaNum(ByRef r As Object) As Integer
Dim rPara As Object
Dim CurPos As Long
r.Select
CurPos = ActiveDocument.Bookmarks("\startOfSel").Start
Set rPara = ActiveDocument.Range(Start:=0, End:=CurPos)
GetParaNum = rPara.Paragraphs.Count
End Function
Try:
Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range
With ActiveDocument
Set Rng = .Range(0, 0)
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "following."
.Replacement.Text = ""
.Format = False
.Forward = True
.Wrap = wdFindStop
.Execute
End With
If .Find.Found = True Then
Rng.End = .Duplicate.End
Rng.Delete
End If
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "Affirmative Defenses"
.Replacement.Text = ""
.Format = False
.Forward = True
.Wrap = wdFindStop
.MatchCase = True
.Execute
End With
If .Find.Found = True Then
Set Rng = .Duplicate
Rng.End = ActiveDocument.Range.End
Rng.Delete
End If
End With
End With
Application.ScreenUpdating = True
End Sub
I´d like to change the style of several words within the active document.
Each word could appear more than once.
Some words are bold and some are unbold.
The words are stored in array Arr().
If the word X found is unbold, replace the style to StyleA and if it is bold change it to StyleB.
The following code has two issues.
1) Words with bold and not bold format change to StyleA.
2) The execution time is slow. I tested the loop from 1 to 5 and it took almost a minute.
Sub ReplaceStyle()
Dim Arr(1 to 200)
Arr(1) = "Word1"
Arr(2) = "Word2"
.
.
.
Arr(200) = "Word200"
For i = 1 To Ubound(Arr)
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = Arr(i)
.Replacement.Text = ""
If Selection.Font.Bold = False Then
.Replacement.Style = ActiveDocument.Styles("StyleA")
Else
.Replacement.Style = ActiveDocument.Styles("StyleB")
End If
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With
Next
End Sub
The logic of the code in the question is faulty. Find needs to have actually located the search term before code can test whether it's bold or not bold.
Two basic approaches would be possible
Search the term, when found perform the test and apply the style
Search each term twice, once for bold and once for not bold
You'd need to test, but based on experience I believe the second approach would be faster as it can use ReplaceAll.
The code below demonstrates the principle, based on the code in the question. Note that it uses a Range object, rather than Selection as this is generally more efficient.
Sub FindReplaceFormattingVariations()
Dim rng As Word.Range
Dim searchTerm As String
Dim Arr(1 to 200)
Arr(1) = "Word1"
Arr(2) = "Word2"
.
.
.
Arr(200) = "Word200"
For i = 1 To Ubound(Arr)
searchTerm = Arr(i)
Set rng = ActiveDocument.content
With rng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = searchTerm
.Font.Bold = True
.Replacement.Style = ActiveDocument.Styles("StyleA")
.Execute Replace:=wdReplaceAll
End With
With rng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = searchTerm
.Font.Bold = False
.Replacement.Style = ActiveDocument.Styles("StyleB")
.Execute Replace:=wdReplaceAll
End With
Next
End Sub
I have a Find and Replace macro that adds a space between the end of one sentence and the beginning of another when missing. This sometimes happens when I move sentences around in word.
I notice that if the cursor is to either side of the punctuation mark, the macro can’t see the Find pattern and doesn’t fix it. I assume it’s because Find and Replace starts searching from the cursor position. Is there a way to tweak the code so it finds them too?
I know I could just tell the macro to start from the beginning, but I would much rather it left the cursor in its current position, especially if I run it near the end of a long document.
Sub AddOneSpaceBetweenSentences()
' AddOneSpaceBetweenSentences Macro
'
With Selection.Find
.Forward = True
.Text = "(?)([.\?\!])([A-Z])"
.ClearFormatting
.Replacement.Text = "\1\2 \3" 'there is a space between \2 and \3
.MatchWildcards = True
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
End Sub
Better still:
Sub AddOneSpaceBetweenSentences()
Application.ScreenUpdating = False
With ActiveDocument.Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Format = False
.MatchWildcards = True
.Wrap = wdFindContinue
.Text = "([.\?\!])([A-Z])"
.Replacement.Text = "\1 \2"
.Execute Replace:=wdReplaceAll
End With
Application.ScreenUpdating = True
End Sub
The most reliable way is to use Range objects instead of Selection. When working with a Range the selection in the document doesn't change.
Sub AddOneSpaceBetweenSentences()
' AddOneSpaceBetweenSentences Macro
'
Dim rng as Word.Range
Set rng = ActiveDocument.Content
With rng.Find
.Forward = True
.Text = "(?)([.\?\!])([A-Z])"
.ClearFormatting
.Replacement.Text = "\1\2 \3" 'there is a space between \2 and \3
.MatchWildcards = True
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
End Sub
Is it really necessary to have a character before the end signs . or ? or !
If not, just replace "([.\?\!])([A-Z])" by "\1 \2"
Simple attempt: Just extend the selection by 2 characters to the left.
If cursor is on the first two characters of the documents, you would get an error. To prevent that and to prevent counting of characters, I just used Selection.Start > 10
If Selection.Start > 10 Then
Selection.Previous(Unit:=wdCharacter, Count:=2).Select
End If
... or do it a little more complicated:
Sub AddOneSpaceBetweenSentences()
Dim SearchText As String
Dim ReplaceText As String
' extend selection by 1 character
If Selection.Start > 0 Then
Selection.Previous(Unit:=wdCharacter, Count:=1).Select
End If
Selection.Collapse
' if selection begins directly before end of sentence (.?!)
' adapt search & replace pattern
If InStr(1, ".?!", Selection.Characters(1), vbBinaryCompare) > 0 Then
SearchText = "([.\?\!])([A-Z])"
ReplaceText = "\1 \2"
Else
SearchText = "(?)([.\?\!])([A-Z])"
ReplaceText = "\1\2 \3"
End If
With Selection.Find
.Forward = True
.text = SearchText
.ClearFormatting
.Replacement.text = ReplaceText
.MatchWildcards = True
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
End Sub
We are trying to revise rtf docs that are created by Molecular Device software.
Here is an example of part of one of these documents:
Protocol 'C:\ALL USERS\Params\Current\2017 Opto Params\0 VoltageClampContinuous.pro' opened.
C:\ALL USERS\Alan\2018_07_11\2018_07_11_0000.abf started at 00:19:48 stopwatch time.
So for right now - all I am trying to do is automatically find the experiment date (in this case = "2018_07_11_")
My sub so far can find the correct cursor positions but how do I select the text between 2 cursor positions?
Below is what I have the CursorPosition statement is of course wrong - this is what I am looking to correct.
Sub FindfilenameDate()
txt_prior_to_expDate = "\"
txt_after_expDate = "0000"
With ActiveDocument.Content.Find
.Text = txt_after_expDate
.Forward = True
.Execute
If .Found = True Then
.Parent.Select
Set after_rng = Selection.Range
expDateEnd_cursorPos = after_rng.Start - 1
Selection.HomeKey Unit:=wdStory, Extend:=wdExtend
With Selection.Find
.Text = txt_prior_to_expDate
.Forward = False
.Execute
If .Found = True Then
.Parent.Select
Set charBefore_expDate = Selection.Range
expDateStart_cursorPos = charBefore_expDate.Start + 1
End If
End With
End If
End With
'expDate = CursorPosition(expDateStart_cursorPos, expDateEnd_cursorPos)
'MsgBox ("expDate = " & expDate) 'DELETEMSGBOX
End Sub
The trick to something like this is to work with multiple Range objects. My personal preference is to declare a Range for each separate thing to be worked with, rather than trying to figure out the minimum and re-use a Range - at least for the initial code and testing purposes.
For this task, then, I use four Ranges: 1) For the original search, 2) for the end of the "cursor position" that's wanted, 3) For the second search, 4) for the final "cursor position".
The other important concepts are how to "collapse" a Range and how to "copy" one.
Collapsing a Range is like pressing the right- or left-arrow key with a selection, so that it is a "point" and doesn't contain anything. A Range can be collapsed to its start or end position.
Copying a Range (setting one Range to another) needs to be done using the Duplicate property so that the copy is independent of the original. Otherwise, when one is changed the other changes, as well.
Sub FindfilenameDate()
Dim rngFind As Word.Range, rngBefore As Word.Range
Dim rngAfter As Word.Range, rngFound As Word.Range
txt_prior_to_expDate = "\"
txt_after_expDate = "0000"
Set rngFind = ActiveDocument.content
With rngFind.Find
.Text = txt_after_expDate
.Forward = True
.Execute
If .found = True Then
Set rngAfter = rngFind.Duplicate
rngAfter.Collapse wdCollapseStart
Set rngBefore = rngFind.Duplicate
rngBefore.Collapse wdCollapseStart
With rngBefore.Find
.Text = txt_prior_to_expDate
.Forward = False
.Execute
If .found = True Then
Set rngFound = rngBefore.Duplicate
rngFound.Collapse wdCollapseEnd
rngFound.End = rngAfter.Start
'rngFound.Select
End If
End With
End If
End With
'expDate = CursorPosition(expDateStart_cursorPos, expDateEnd_cursorPos)
MsgBox ("expDate = " & rngFound.Text) 'DELETEMSGBOX
End Sub
Though it's not apparent why you're after the date string ending in _0000 rather than the date that is the parent folder name, a much simpler approach for a single date would be:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "[0-9]{4}_[0-9]{2}_[0-9]{2}_0000"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
If .Find.Found = True Then MsgBox "expDate = " & Split(.Text, "_0000")(0)
End With
Application.ScreenUpdating = True
End Sub
And, for all such dates in a document:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "[0-9]{4}_[0-9]{2}_[0-9]{2}_0000"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
Do While .Find.Found = True
MsgBox "expDate = " & Split(.Text, "_0000")(0)
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Application.ScreenUpdating = True
End Sub