I try to use Find.FindText in Word VBA to find the first few letters of a word, then select the rest of that word. For example, if I have:
"Hello , AB-1234-123 check"
I would find "AB-" then select the rest of the word to get "AB-1234-123". I cannot use space as my MoveEndUntil(" ") because, sometimes, the word ends with a period.
So far, my code is
SearchString = "AB-"
With Rng.Find
Do While .Execute(FindText:=SearchString, Forward:=True) = True
Rng.MoveEndUntil (" ")
MsgBox (Rng.Text)
Loop
End With
You can still use MoveEndUntil. If you look at the Help topic for the method, you'll see that the first parameter, named CSet, can hold multiple characters. So it can look for a space as well as a period, a comma, a semicolon, etc.
While testing your code, it also came to my attention that, as it stands, it will go into a continuous loop - always finding only the first instance. So I've taken care of that with the Collapse method so that the next Find sequence starts immediately after the last "found" range.
Dim rng As word.Range
Dim SearchString As String
Set rng = ActiveDocument.content
SearchString = "AB-"
With rng.Find
Do While .Execute(findText:=SearchString, Forward:=True) = True
rng.MoveEndUntil (" .,;!")
MsgBox rng.Text
rng.Collapse wdCollapseEnd
Loop
End With
Perhaps you can select the found word portion, then expand it to the whole word?
Selection.Expand Unit:=wdWord
Related
I'm coding a macro to check French texts and correct typographical errors (such as punctuation, spaces before punctuation, etc.). Screen updating is off, but the revisions are tracked so that at the end of the execution, the author sees where spaces have been inserted or the punctuation changed. The program consists of a "main sub" that calls specific subs one by one (one sub to insert spaces, then one for changing the quotation marks, etc.).
Since I have to search for specific characters (and not entire words) and mostly insert or delete things (and not replace), I tried to avoid "Find and Replace", because with this method I would see revision marks on elements that are not wrong but only help me to find the element to correct (for example: insertion of a space before "?" => If I use "Find and Replace", the author will see that "word?" is replaced by "word ?", as if the word was wrong, instead of just seeing that a space has been inserted).
The solution I found is to search an expression with wildcards first to isolate the problematic segments (for example: "[a-zA-Z0-9]?) and then search again inside this segment for the right position to insert something or the right element to change. That way, I can aim at the exact element I have to change and the revisions are marked exactly (see code below).
Sub Guillemets()
'Index
Dim vKey As Variant
'Variables for the forloop
Dim rRng As Range
Dim bFound As Boolean
Dim rChange As Range
'#############################---FOR LOOP: quotation marks---#############################
Dim dictGuill1 As Scripting.Dictionary
Set dictGuill1 = New Scripting.Dictionary
'German and English quotation marks: dictionnary to cover all different cases
dictGuill1.Add Key:=ChrW(8220) & "([a-zA-Z0-9])", Item:=Array(ChrW(8220), Chr(171) & "^s")
dictGuill1.Add Key:=ChrW(34) & "([a-zA-Z0-9])", Item:=Array(ChrW(34), Chr(171) & "^s")
dictGuill1.Add Key:=Chr(171) & " ", Item:=Array(" ", "^s")
dictGuill1.Add Key:=" " & Chr(187), Item:=Array(" ", "^s")
For Each vKey In dictGuill1.Keys
'Debug.Print (vKey)
Set rRng = Selection.Range.Duplicate
Set rChange = rRng.Duplicate
rChange.Collapse (wdCollapseStart)
'Debug.Print ("rRng: " & rRng)
'Debug.Print ("rChange: " & rChange)
Do
Set rRng = Selection.Range.Duplicate
'Debug.Print ("Selection dupliquée: " & rRng)
rRng.Find.Replacement.ClearFormatting
rRng.Find.ClearFormatting
rRng.Start = rChange.End
'To prevent the search to start over and get stuck on the same element
With rRng.Find
'Debug.Print ("rRng: " & rRng)
.Text = vKey
.MatchWildcards = True
.MatchWholeWord = True
.Forward = True
.Wrap = wdFindStop
bFound = .Execute
End With
'Debug.Print ("Found? " & bFound)
'Debug.Print ("Found index: " & rRng.Start)
If bFound Then
Set rChange = rRng.Duplicate
'Debug.Print ("Before correction: " & rChange)
With rChange.Find
.Text = dictGuill1(vKey)(0)
.Replacement.Text = dictGuill1(vKey)(1)
.Execute Replace:=wdReplaceOne
End With
'Debug.Print ("After correction: " & rChange)
End If
Loop While bFound = True
Next vKey
The forloop works and bring the expected result. The only thing is that it is slow, especially when the text is long. Plus, for some subs, I have dozens of cases and have to deal with the fact that some cases leads to an insertion of space (range.InsertBefore, range.InsertAfter) and others to the replacement of a character.
I would like to find a way to improve this algorithm. Is there a way to avoid this second search or to fuse it with the first one to reduce the complexity of the algorithm and still have "correct" revision marks?
Thanks in advance for your help/advice.
I have a simple loop (below) that looks for sentences over 30 words long. If found, it adds a comment box to the selected sentence. It worked fine in testing. Then I added some test endnote citations...and it fails to find the long sentences.
However, it only fails when there is no space between the period and the citation superscript. If I add a space, it finds it and works perfectly. The problem is, there is not suposed to be a space between the period and the citation, per the style guide I have to follow at work.
This related Stack thread discusses the need for a space after a period to delineate the end of a sentence. I am assuming the space must be directly after the period, because I have spaces in my citations like this 1, 2, 3
Question
How can I find instances of period+superscript (with no space like this --> This is a sentence.1, 2, 3) and add a space? Ideally I would like this to happen within the below loop so I can remove the space after the comment gets added.
Sub Comment_on_Long_Sentences ()
Dim iWords as Integer
iWords = 0
For Each MySent in ActiveDocument.Sentences
If MySent.Words.Count > iWords Then
MySent.Select
'find and delete space
ActiveDocument.Comments.Add Range:= Selection.Range, Text:= "Long Sentence: " & iWords & " words"
'put the space back
End if
Next MySent
End Sub
There appears to be issues in VBA when trying to access Sentences that end with a superscript character. Your code also has problems with non-declared variables, so I have no idea how it ever worked for you in the first place.
Try this following VBA routine, it works in my environment. Also notice the special handling that I found is required for 1st sentences in paragraphs and when that sentence ends with a superscript character.
Sub Comment_on_Long_Sentences()
Dim doc As word.Document, rng As word.Range, para As word.Paragraph
Dim i As Long
Set doc = ActiveDocument
For Each para In doc.Paragraphs
Debug.Print para.Range.Sentences.Count
For i = 1 To para.Range.Sentences.Count
Set rng = para.Range.Sentences(i)
If i = 1 And rng.Characters.First.Font.Superscript = True Then
rng.MoveStart word.WdUnits.wdSentence, Count:=-1
End If
If rng.words.Count > 30 Then
doc.Comments.Add Range:=rng, Text:="Long Sentence: " & rng.words.Count & " words"
End If
Next
Next
End Sub
Here is an alternative solution. Note the option explicit at the start. Its good VBA practice to put this at the top of every module.
The problem you have is very common. Find something then rather than do a replace, do some other non replace related stuff. The subs to add and remove spaces before citations implement this pattern and are well worth studying.
If you don't understand anything then in the VBA IDE just put your cursor on the relevant keyword and press F1. This will bring up the relevant MS help page.
Option explicit
Sub Comment_on_Long_Sentences()
Dim iWords As Integer
Dim my_sentence As Variant
iWords = 30
AddSpaceBeforeCitations
For Each my_sentence In ActiveDocument.Sentences
If my_sentence.Words.Count > iWords Then
my_sentence.Comments.Add Range:=my_sentence, Text:="Long Sentence: " & iWords & " words"
End If
Next my_sentence
RemoveSpaceBeforeCitations
End Sub
Sub AddSpaceBeforeCitations()
With ActiveDocument.Content
With .Find
.ClearFormatting
.Format = True
.Text = ""
.Wrap = wdFindStop
.Font.Superscript = True
.Execute
End With
Do While .Find.Found
With .Previous(unit:=wdCharacter, Count:=1).characters
If .Last.Text = "." Then
.Last.Text = ". "
End If
End With
.Collapse direction:=wdCollapseEnd
.Move unit:=wdCharacter, Count:=1
.Find.Execute
Loop
End With
End Sub
Sub RemoveSpaceBeforeCitations()
With ActiveDocument.Content
With .Find
.ClearFormatting
.Format = True
.Text = ""
.Wrap = wdFindStop
.Font.Superscript = True
.Execute
End With
Do While .Find.Found
With .Previous(unit:=wdCharacter, Count:=2).characters
If (.Last.Text = ".") Then
.Last.Next(unit:=wdCharacter, Count:=1).characters.Last.Text = vbNullString
End If
End With
.Collapse direction:=wdCollapseEnd
.Move unit:=wdCharacter, Count:=1
.Find.Execute
Loop
End With
End Sub
No matter what approach you take, any code that relies on the VBA .Sentence property or .Word property is going to produce unreliable results. That's because .Sentence has no idea what a grammatical sentence and .Word has no idea what a grammatical word is. For example, consider the following:
Mr. Smith spent $1,234.56 at Dr. John's Grocery Store, to buy 10.25kg of potatoes, 10kg of avocados, and 15.1kg of Mrs. Green's Mt. Pleasant macadamia nuts.
For you and me, that would count as one, 26-word sentence; for VBA it counts as 5 sentences containing 45 words overall. For an accurate word count, use .ComputeStatistics(wdStatisticWords). Sadly there is no .ComputeStatistics(wdStatisticSentences) equivalent for sentences.
I have a code like so:
Sub MoveToBeginningSentence()
Application.ScreenUpdating = False
Dim selectedWords As Range
Dim selectedText As String
Const punctuation As String = " & Chr(145) & "
On Error GoTo ErrorReport
' Cancel macro when there's no text selected
Selection.Cut
Selection.MoveLeft Unit:=wdSentence, Count:=1, Extend:=wdMove
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Set selectedWords = Selection.Range
selectedText = selectedWords
If InStr(selectedText, punctuation) = 0 Then
Selection.MoveLeft Unit:=wdSentence, Count:=1, Extend:=wdMove
Selection.Paste
Else
Selection.MoveLeft Unit:=wdSentence, Count:=1, Extend:=wdMove
Selection.Paste
Selection.Paste
Selection.Paste
Selection.Paste
End If
ErrorReport:
End Sub
Basically, it help me move whatever text I have selected to the beginning of the sentence in Word. If there's no quotation mark, then paste once. If there is a quote mark, paste 4 times.
The problem is regardless of whether there's any quotation there or not, it will only paste once. If I set the macro to detect any other character, it will work fine. But every single time I try to force it to detect smart quotations, it will fail.
Is there any way to fix it?
Working with the Selection object is always a bit chancy; on the whole, it's better to work with a Range object. You can have only one Selection; you can have as many Ranges as you need.
Because your code uses the Selection object it's not 100% clear what the code does. Based on my best guess, I put together the following example which you can tweak if it's not exactly right.
At the beginning, I check whether there's something in the selection, or it's a blinking insertion point. If no text is selected, the macro ends. This is better than invoking Error handling, then not handling anything: If other problems crop up in your code, you wouldn't know about them.
A Range object is instantiated for the selection - there's no need to "cut" it, as you'll see further along. Based on this, the entire sentence is also assigned to a Range object. The text of the sentence is picked up, then the sentence's Range is "collapsed" to its starting point. (Think of this like pressing the left arrow on the keyboard.)
Now the sentence's text is checked for the character Chr(145). If it's not there, the original selection's text (including formatting) is added at the beginning of the sentence. If it's there, then it's added four times.
Finally, the original selection is deleted.
Sub MoveToBeginningSentence()
Application.ScreenUpdating = False
Dim selectedText As String
Dim punctuation As String
punctuation = Chr(145) ' ‘ "smart" apostrophe
Dim selRange As word.Range
Dim curSentence As word.Range
Dim i As Long
' Cancel macro when there's no text selected
If Selection.Type = wdSelectionIP Then Exit Sub
Set selRange = Selection.Range
Set curSentence = selRange.Sentences(1)
selectedText = curSentence.Text
curSentence.Collapse wdCollapseStart
If InStr(selectedText, punctuation) = 0 Then
curSentence.FormattedText = selRange.FormattedText
Else
For i = 1 To 4
curSentence.FormattedText = selRange.FormattedText
curSentence.Collapse wdCollapseEnd
Next
End If
selRange.Delete
End Sub
Please check out this code.
Sub MoveToBeginningSentence()
' 19 Jan 2018
Dim Rng As Range
Dim SelText As String
Dim Repeats As Integer
Dim i As Integer
With Selection.Range
SelText = .Text ' copy the selected text
Set Rng = .Sentences(1) ' identify the current sentence
End With
If Len(SelText) Then ' Skip when no text is selected
With Rng
Application.ScreenUpdating = False
Selection.Range.Text = "" ' delete the selected text
Repeats = IIf(IsQuote(.Text), 4, 1)
If Repeats = 4 Then .MoveStart wdCharacter, 1
For i = 1 To Repeats
.Text = SelText & .Text
Next i
Application.ScreenUpdating = True
End With
Else
MsgBox "Please select some text.", _
vbExclamation, "Selection is empty"
End If
End Sub
Private Function IsQuote(Txt As String) As Boolean
' 19 Jan 2018
Dim Quotes
Dim Ch As Long
Dim i As Long
Quotes = Array(34, 147, 148, -24143, -24144)
Ch = Asc(Txt)
' Debug.Print Ch ' read ASCII code of first character
For i = 0 To UBound(Quotes)
If Ch = Quotes(i) Then Exit For
Next i
IsQuote = (i <= UBound(Quotes))
End Function
The approach taken is to identify the first character of the selected sentence using the ASC() function. For a normal quotation mark that would be 34. In my test I came up with -24143 and -24144 (opening and closing). I couldn't identify Chr(145) but found MS stating that curly quotation marks are Chr(147) and Chr(148) respectively. Therefore I added a function that checks all of them. If you enable the line Debug.Print Ch in the function the character code actually found will be printed to the immediate window. You might add more character codes to the array Quotes.
The code itself doesn't consider spaces between words. Perhaps Word will take care of that, and perhaps you don't need it.
You need to supply InStr with the starting position as a first parameter:
If InStr(1, selectedText, punctuation) = 0 Then
Also
Const punctuation As String = " & Chr(145) & "
is going to search for space-ampersand-space-Chr(145)-space-ampersand-space. If you want to search for the smart quote character then use
Const punctuation As String = Chr(145)
Hope that helps.
I have a script that looks for some text, inputted by the user. The idea is to look through a document for this text, and when it's found, select the paragraph and ask the user if they want to add this paragraph to an Index.
For some reason, I can't get the script to move past the first selected paragraph. When I run it, and click "Yes" in the UserForm (equivalent of myForm.Tag = 2), it adds to the index, but then when the .Find looks for the next instance of the text, it selects the paragraph I just had highlighted. ...it doesn't continue.
Here's the code:
Sub find_Definitions()
Dim defText As String, findText$
Dim oRng As Word.Range, rng As Word.Range
Dim myForm As frmAddDefinition
Set myForm = New frmAddDefinition
Dim addDefinition$, expandParagraph&
' expandParagraph = 1
Set oRng = ActiveDocument.Range
findText = InputBox("What text would you like to search for?")
With oRng.Find
.Text = findText
While .Execute
Set rng = oRng.Paragraphs(1).Range
rng.Select
defText = oRng.Paragraphs(1).Range
myForm.Show
Select Case myForm.Tag
Case 0 ' Expand the paragraph selection
Do While CLng(expandParagraph) < 1
expandParagraph = InputBox("How many paragraphs to extend selection?")
If expandParagraph = 0 Then Exit Do
Loop
rng.MoveEnd unit:=wdParagraph, Count:=expandParagraph
rng.Select
defText = rng
ActiveDocument.Indexes.MarkEntry Range:=rng, entry:=defText, entryautotext:=defText
Case 1 ' No, do not add to the index
' do nothing
Case 2 ' Yes, add to index
ActiveDocument.Indexes.MarkEntry Range:=rng, entry:=defText, entryautotext:=defText
Case 3 ' Cancel, exit the sub
MsgBox ("Exiting macro")
GoTo lbl_Exit
End Select
Wend
End With
lbl_Exit:
Unload myForm
Set myForm = Nothing
End Sub
(FWIW, I'm pretty new to Word VBA, but very familiar with Excel VBA). Thanks for any ideas.
Note if I click "No" (equivalent of myForm.Tag = 1), then it does move on to the next instance. Hmm.
Try adding rng.Collapse wdCollapseEnd before the "Case 1" line.
Explanation: When you use Find, it executes on the given Range or Selection.
If it's successful, that Range/Selection changes to include the "found" term. In this case, you in addition change the assignment again (expanding to include the paragraph).
When your code loops the current assignment to "Range" is used - in this case, Find looks only at the selected paragraph Range. So you need to reset the Range in order to have Find continue.
To be absolutely accurate, after Collapse you could also add:
rng.End = ActiveDocument.Content.End
Note: it's more correct to use ActiveDocument.Content than ActiveDocument.Range. ActiveDocument.Range is actually a method for creating a new Range by specifying the Start and End points, while ActiveDocument.Content returns the entire main story (body) of the document as a Range object. VBA doesn't care, it defaults the method to return the main story. Other programming languages (.NET, especially C#) don't work as intuitively with Word's object model, however. So it's a good habit to use what "always" works :-)
I have created the following to comma separate a list of numbers within a ms-word document. However, I also want to wrap each number with single qoutation marks - which I am struggling to get right. I have managed to wrap the first number however I cant execute it for the others. Each number is 12 digits long. Can someone assist?
Sub Macro1()
With Selection
.Find.Text = "^p"
.Find.Replacement.Text = ","
.Find.Execute Replace:=wdReplaceAll
.TypeText Text:="'"
.MoveRight Unit:=wdCharacter, Count:=12
.TypeText Text:="'"
End With
End Sub
Alternative and quicker solution is to use wildcards for another find-replace. Complete code will look as follows:
Sub Macro1()
With Selection
'1st step- replacement paragraph marks into commas
.Find.Text = "^p"
.Find.Replacement.Text = ","
.Find.MatchWildcards = False
.Find.Execute Replace:=wdReplaceAll
'2nd step- adding single quotation marks
.Find.Text = "([0-9]{12})"
.Find.MatchWildcards = True
.Find.Replacement.Text = "'\1'"
.Find.Execute Replace:=wdReplaceAll
End With
End Sub
You need to move the transformation outside of the With block, I think.
I am not a Word VBA expert, so this is an approach that uses common string functions, rather than replicating keyboard input. So, there are likely different approaches to accomplish the same task :) I suspect this is the "correct" way to do it, since it's generally advisable not to mimic "input" but rather to work directly with the objects.
Revised so that you do not need to physically "Select" the text
Note: this uses all text in the document, so you may need to modify.
Sub Test()
Dim doc As Document
Dim arr As Variant
Dim txtRange As Range
Dim i As Long
Set doc = ActiveDocument
Set txtRange = doc.Range(0, doc.Characters.Count)
'First, replace the paragraph breaks with commas
With txtRange.Find
.Text = "^p"
.Replacement.Text = ","
.Execute Replace:=wdReplaceAll
End With
arr = Split(Left(txtRange.Text, Len(txtRange.Text) - 1), ",")
For i = LBound(arr) To UBound(arr)
arr(i) = "'" & arr(i) & "'"
Next
txtRange.Text = Join(arr, ",")
End Sub
UPDATE FROM COMMENTS
I have confirmed absolutely that this is working. Please double-check that you have implemented the code correctly. Here is an example of some text which meets your description:
I select that text, and run the macro, stepping through it using F8. At the end of the With block, observe that the paragraph breaks have been replaced with commas:
After the For...Next loop has exited, I confirm using the Locals window, that the new array now contains numbers enclosed in single quotes:
The next line prints out those items from the array, and replaces the Selection.Text, confirmed:
I have re-worked my original code, and this runs really quickly over large data sets. I've now added in brackets at the start and end of the code too.
Sub TestN()
Options.AutoFormatAsYouTypeReplaceQuotes = False
'Replace the paragraph breaks with commas and single quotes
With ActiveDocument.Range(0, ActiveDocument.Range.End - 1).Find
.Text = "^p"
.Replacement.Text = "','"
.Execute Replace:=wdReplaceAll
End With
Options.AutoFormatAsYouTypeReplaceQuotes = True
'Cap body of data with single quotes and brackets
ActiveDocument.Content.Text = "('" & ActiveDocument.Range(0, ActiveDocument.Range.End - 1).Text & "')"
End Sub