I'm working on a script that extracts parenthetical in-text citations like '(Author, 1992)' from a word doc and copies them to another doc. The code works well to extract all parentheticals, but there are cases where a citation is in the form of "as quoted in Author (1992)..." Where a parenthetical starts with a number, I would like to pull the previous word into the range and copy both over into the new doc. In the above scenario then, we would get 'Author (1992)' rather than just '(1992)' as the code currently operates. I have tried writing a conditional to modify the range using .MoveStart, but it is not capturing the preceding word when the range copies over to the new doc. I know I'm missing some small, significant piece here but can't find any obvious (to me) solutions on other forums questions. Thanks
Sub CopyRefs()
Dim SearchRange As Range, DestinationDoc$, SourceDoc$
DestinationDoc$ = "Extracted_References.doc"
SourceDoc$ = ActiveDocument.Name
Documents.Add DocumentType:=wdNewBlankDocument
ActiveDocument.SaveAs DestinationDoc$, wdFormatDocument
Documents(SourceDoc$).Activate
Set SearchRange = ActiveDocument.Range
With SearchRange.Find
Do While .Execute(findText:="\(*\)", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True
'this part doesn't seem to work when condition is satisfied
If SearchRange.Text Like "\(#*" Then
SearchRange.MoveStart wdWord, -1
End If
'a parenthetical number like (1992) will copy over to new doc but seems_
'like range not updating to include preceding word in previous step
Documents(DestinationDoc$).Range.InsertAfter SearchRange.Text & vbCr
Loop
End With
End Sub
Thanks to jonsson for pointing out the syntax error. Code below functions as intended.
Sub CopyRefs()
Dim SearchRange As Range, DestinationDoc$, SourceDoc$
DestinationDoc$ = "Extracted_References.doc"
SourceDoc$ = ActiveDocument.Name
Documents.Add DocumentType:=wdNewBlankDocument
ActiveDocument.SaveAs DestinationDoc$, wdFormatDocument
Documents(SourceDoc$).Activate
Set SearchRange = ActiveDocument.Range
With SearchRange.Find
Do While .Execute(findText:="\(*\)", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True
'Removed backslash since "(" doesn't need to be escaped
If SearchRange.Text Like "(#*" Then
SearchRange.MoveStart wdWord, -1
End If
'copies range to new doc
Documents(DestinationDoc$).Range.InsertAfter SearchRange.Text & vbCr
'collapses range to prevent infinite loop when If condition met
SearchRange.Collapse wdCollapseEnd
Loop
End With
End Sub
Related
I am trying to delete ALL empty paragraphs at the start of a Word file. I am using the following to delete just the FIRST paragraph but I need to delete all empty paragraphs in a row, so that if you have 5 empty lines, they will all be deleted.
here is the code:
Dim MyRange As Range
Set MyRange = ActiveDocument.Paragraphs(1).Range
If MyRange.Text = vbCr Then MyRange.Delete
I've tried adding a loop and for statement, but to no avail.
thanks in advance.
Collapse to the start of the document, then extend the range whilst 'empty characters' are found.
Here is your starter for 10
Dim MyRange As Range
Set MyRange = ActiveDocument.Paragraphs(1).Range
MyRange.Collapse direction:=wdCollapseStart
MyRange.MoveEndWhile cset:=" " & vbCrLf ' & any other invisible characters that may be present
MyRange.Delete
Each paragraph must have at least one character - the paragraph mark itself. So all we need to do is to check if the paragraph contains only 1 character.
Simple like this:
Sub ClearEmptyPargraphAtStartOfDocument()
While (ActiveDocument.Paragraphs(1).Range.Characters.Count = 1)
ActiveDocument.Paragraphs(1).Range.Delete
Wend
End Sub
This seems to work for me
Public Sub SOCheck()
Dim MyRange As Range, CarryOn As Boolean
CarryOn = True
While CarryOn
Set MyRange = ActiveDocument.Paragraphs(1).Range
If MyRange.Text = vbCr Then
MyRange.Delete
Else
CarryOn = False
End If
Wend
'MsgBox "Done"
End Sub
It's just a loop around your own code
I feel I must be missing something obvious. I'm using VBA to build a Word document by writing lines to it one at a time. Once I've written a line, I need to format it - this could be bolding, setting tabstops, etc. But in order to format a line, I have to be able to refer to it. All the formatting facilities operate on a Range or a Selection - how do I identify the line I've just inserted as the Range I want to operate on? (Also, same question for table rows, as the doc also includes tables I'm building one row at a time, and I need to format cells as I go).
This is how to insert text and format it as you go, using a Range object. It's better to not try to simulate how a user works by using Selection and TypeText. The code runs more slowly and it's more difficult to work precisely. There can be only one Selection, but code can work with many Ranges...
The other important point to remember is to declare and instantiate objects as they're created - tables and table rows, for example.
Dim rng1 as Word.Range, rng2 as Word.Range
Set rng1 = ActiveDocument.Content
rng1.Text = "line one" & vbCr
rng1.Font.Bold = True
rng1.Collapse wdCollapseEnd
rng1.Text = "line two" & vbCr
rng1.Font.Bold = False
rng1.Collapse wdCollapseEnd
Set rng2 = rng1.Duplicate
rng2.Text = "line three" & vbCr
rng2.Font.Italic = True
'You can still work with the first range
rng1.ParagraphFormat.Alignment = wdAlignParagraphCenter
'
Dim tbl as Word.Table, rw1 as Word.Row, rw2 as Word.Row
Set tbl = ActiveDocument.Tables.Add
Set rw1 = tbl.Rows(1)
Set r2 = tbl.Rows.Add
Sub FormatBold()
Dim StartWord As String, EndWord As String
StartWord = "STARTSTART"
EndWord = "ENDEND"
With ActiveDocument.Content.Duplicate
.Find.Execute Findtext:=StartWord & "*" & EndWord, MatchWildcards:=True
.MoveStart wdCharacter, Len(StartWord)
.MoveEnd wdCharacter, -Len(EndWord)
.Font.Bold = True ' Or whatever you want to do
End With
End Sub
Format the text while you write it:
Sub StartTyping()
Selection.TypeText Text:="This is the "
Selection.Font.Bold = wdToggle
Selection.TypeText Text:="sentence"
Selection.Font.Bold = wdToggle
Selection.TypeText Text:=" I am inserting." & vbCr
End Sub
I'm new to VBA and would greatly appreciate some help on a problem.
I have long Word documents where I need to apply standard comments to the same set of keywords, but only in selected sections of the document. The following macro worked to find a keyword and apply a comment (from question here https://superuser.com/questions/547710/macro-to-insert-comment-bubbles-in-microsoft-word):
Sub label_items()
'
' label_items Macro
'
'
Do While Selection.Find.Execute("keyword1") = True
ActiveDocument.Comments.Add range:=Selection.range, Text:="comment for keyword 1"
Loop
End Sub
The two modifications are:
1) only apply the comments to user selected text, not the whole document. I tried a "With Selection.Range.Find" approach but I don't think comments can be added this way (??)
2) repeat this for 20+ keywords in the selected text. The keywords aren't totally standard and have names like P_1HAI10, P_1HAI20, P_2HAI60, P_HFS10, etc.
EDIT: I have tried to combine code from similar questions ( Word VBA: finding a set of words and inserting predefined comments and Word macro, storing the current selection (VBA)) but my current attempt (below) only runs for the first keyword and comment and runs over the entire document, not just the text I have highlighted/selected.
Sub label_items()
'
' label_items Macro
'
Dim selbkup As range
Set selbkup = ActiveDocument.range(Selection.range.Start, Selection.range.End)
Set range = selbkup
Do While range.Find.Execute("keyword 1") = True
ActiveDocument.Comments.Add range, "comment for keyword 1"
Loop
Set range = selbkup
Do While range.Find.Execute("keyword 2") = True
ActiveDocument.Comments.Add range, "comment for keyword 2"
Loop
'I would repeat this process for all of my keywords
End Sub
I've combed through previous questions and the Office Dev Center and am stuck. Any help/guidance is greatly appreciated!
It's a matter of adding a loop and a means of Finding the next keyword you're looking for. There are a few suggestions in the code example below, so please adjust it as necessary to fit your requirements.
Option Explicit
Sub label_items()
Dim myDoc As Document
Dim targetRange As Range
Set myDoc = ActiveDocument
Set targetRange = Selection.Range
'--- drop a bookmark to return the cursor to it's original location
Const RETURN_BM = "OrigCursorLoc"
myDoc.Bookmarks.Add Name:=RETURN_BM, Range:=Selection.Range
'--- if nothing is selected, then search the whole document
If Selection.Start = Selection.End Then
Selection.Start = 0
targetRange.Start = 0
targetRange.End = myDoc.Range.End
End If
'--- build list of keywords to search
Dim keywords() As String
keywords = Split("SMS,HTTP,SMTP", ",", , vbTextCompare)
'--- search for all keywords within the user selected range
Dim i As Long
For i = 0 To UBound(keywords)
'--- set the cursor back to the beginning of the
' originally selected range
Selection.GoTo What:=wdGoToBookmark, Name:=RETURN_BM
Do
With Selection.Find
.Forward = True
.Wrap = wdFindStop
.Text = keywords(i)
.Execute
If .Found Then
If (Selection.Start < targetRange.End) Then
Selection.Comments.Add Selection.Range, _
Text:="Found the " & keywords(i) & " keyword"
Else
Exit Do
End If
Else
Exit Do
End If
End With
Loop
Next i
'--- set the cursor back to the beginning of the
' originally selected range
Selection.GoTo What:=wdGoToBookmark, Name:=RETURN_BM
End Sub
This is a silly question, but can't figure it out.
Straight from the Microsoft Site:
This example finds every instance of the word "Start" in the active document and replaces it with "End." The find operation ignores formatting but matches the case of the text to find ("Start").
Set myRange = ActiveDocument.Range(Start:=0, End:=0)
With myRange.Find
.ClearFormatting
.Text = "Start"
With .Replacement
.ClearFormatting
.Text = "End"
End With
.Execute Replace:=wdReplaceAll, _
Format:=True, MatchCase:=True, _
MatchWholeWord:=True
End With
I need to know how to make it so it only finds the next instance of Start and replace it with End. This will leave all other Ends intact throughout the document.
You should use wdReplaceOne in place of wdReplaceAll.
You should be able to adapt this:
Sub Tester()
Const FIND_WHAT as String = "Start"
Const REPLACE_WITH as String = "End"
Const REPLACE_WHICH As Long = 4 'which instance to replace?
Dim rng As Range, i As Long
i = 0
Set rng = ActiveDocument.Content
With rng.Find
.ClearFormatting
.Text = FIND_WHAT
Do While .Execute(Format:=True, MatchCase:=True, _
MatchWholeWord:=True)
i = i + 1
If i = REPLACE_WHICH Then
'Note - "rng" is now redefined as the found range
' This happens every time Execute returns True
rng.Text = REPLACE_WITH
Exit Do
End If
Loop
End With
End Sub
This discussion has some useful suggestions: Replace only last occurrence of match in a string in VBA. In brief, it's a case of looping through your search string from start until the first instance of the search argument is located and replacing just that.
I am using the following VBA macro to add page numbers after all bookmark hyperlinks in my document:
Sub InsertPageRefs()
Application.ScreenUpdating = False
Dim hLnk As Hyperlink, Rng As Range
For Each hLnk In ActiveDocument.Hyperlinks
With hLnk
If InStr(.SubAddress, "_Toc") = 0 And .Address = "" Then
Set Rng = .Range
With Rng
.Collapse Direction:=wdCollapseEnd
.InsertAfter Text:=" (See page #)"
.Font.Underline = wdUnderlineNone
End With
ActiveDocument.Fields.Add Range:=Rng.Characters(InStr(Rng, "#")), Text:="PAGEREF " & .SubAddress
End If
End With
Next
Set Rng = Nothing
Application.ScreenUpdating = True
Application.ScreenRefresh
MsgBox ActiveDocument.Hyperlinks.Count & " page numbers have been added.", vbOKOnly
End Sub
However, it's having undesirable results.
The blue color of the hyperlinks is partially spilling over into the added text.
It's creating a bunch of crazy span tags when I save the resulting file to HTML. I don't want this because I am going to convert the HTML to .mobi for Kindle and all the span tags are going to create chaos in my .mobi.
How do I strip out all the formatting and insert the page numbers in the "Normal" word style?
I suspect the real answer for this would be to use a good e-book editor that will keep track of this for you.
That said, the problem is likely that you are working on the Hyperlink's range, so all you should have to do is duplicate it. This allows the formatting of your range separate itself from whatever formatting is attached to the hyperlink. The other benefit of using a duplicate of a Hyperlink's range is that you can operate on the text of the range directly without destroying the link, which is also an easy way to preserve the target formatting:
Sub InsertPageRefs()
Dim hLnk As Hyperlink
Dim Rng As Range
For Each hLnk In ActiveDocument.Hyperlinks
If InStr(hLnk.SubAddress, "_Toc") = 0 And hLnk.Address = vbNullString Then
Set Rng = hLnk.Range.Duplicate
Rng.Start = Rng.End
Rng.Text = " (See page #)"
Rng.Font.Underline = wdUnderlineNone
ActiveDocument.Fields.Add Range:=Rng.Characters(InStr(Rng, "#")), _
Text:="PAGEREF " & hLnk.SubAddress
End If
Next
MsgBox ActiveDocument.Hyperlinks.Count & " page numbers have been added.", vbOKOnly
End Sub
Note that I pulled out the With blocks to make this more readable. Nested Withs make it a lot more difficult to tell at a glance what object you're operating on.