The code is intended to add the same hyperlink to all Heading 1 style text. (Purpose: clicking any heading brings you to the top of the document).
It works for the first Heading Style text. It does not advance to the next instance.
I found this was due to the line which adds the hyperlink. When this line is removed, all the Heading 1 style text is found (but of course then I can't add the link).
Sub addLinksToAllTextHavingCertainStyle()
Dim r As Range
Set r = ActiveDocument.Content
r.Find.ClearFormatting
Do
With r.Find
.Text = ""
.Replacement.Text = ""
.Style = "Heading 1"
.Forward = True
.Wrap = wdFindStop
.Format = True
.Execute
End With
r.Select 'for testing
ActiveDocument.Hyperlinks.Add Anchor:=r, Address:="", SubAddress:="_top", ScreenTip:=""
Loop
End Sub
You're looping the wrong part of the code. As written your code loops the entire find, which means it just starts over from the beginning each time.
It is only the execution of the Find that needs to be looped, the parameters you have set will remain. When Find is executed the range that the Find is executed on is redefined to the found match, so in a loop you need to collapse the range to the end to avoid the match being endlessly re-found.
Sub addLinksToAllTextHavingCertainStyle()
Dim r As Range
Set r = ActiveDocument.Content
With r.Find
.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Style = "Heading 1"
.Forward = True
.Wrap = wdFindStop
.Format = True
End With
Do While r.Find.Execute = True
ActiveDocument.Hyperlinks.Add Anchor:=r, Address:="", SubAddress:="_top", ScreenTip:=""
r.Collapse wdCollapseEnd
Loop
End Sub
Related
I am trying to create a Word macro that will:
Search for a specific word (i.e. "see")
Select the entire paragraph where that word appears
Make the whole paragraph a different style (i.e. make it all red text)
Do the same thing with a second word (i.e. "blacklist")
Select that whole paragraph and apply a different style (i.e. again, make the paragraph red text)
Copy all paragraphs with the red text style and paste them in to a new word document
Unfortunately, I'm no VBA expert and I'm trying to cobble things together from what I can find online. I have found a great example that will select to the start of the paragraph, but I can't seem to figure out how to select the entire paragraph. Any help is appreciated!
** Sorry - here is the code I currently have. It will find all instances of the word "see" and selects to the start of the paragraph, then changes the color to red... but that's as far as I've gotten, as I am stuck on trying to figure out how to get it to select to the end of the paragraph.
Sub TestOne()
'
' TestOne Macro
'
'
If MsgBox(Prompt:="Would you like to update selected paragraph styles?", Buttons:=vbYesNo + vbQuestion, _
Title:="Format MD Report") = vbNo Then
Exit Sub
End If
Application.ScreenUpdating = False
Dim i As Long
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "see"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = False
End With
Do While .Find.Execute
i = i + 1
.Start = .Paragraphs.First.Range.Start
.Font.Color = wdColorRed
.Start = .Paragraphs.First.Range.End
Loop
End With
Application.ScreenUpdating = True
MsgBox i & " instances processed."
End Sub
For example, without needing to create a second document:
Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, StrFnd As String
StrFnd = "see|blacklist"
With ActiveDocument.Range
.Font.Hidden = True
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Text = "^&"
.Font.Hidden = True
.Replacement.Font.Hidden = False
.Format = True
.Forward = True
.MatchWildcards = True
.Wrap = wdFindContinue
For i = 0 To UBound(Split(StrFnd, "|"))
.Text = "[!^13]#" & Split(StrFnd, "|")(i) & "*^13"
.Execute Replace:=wdReplaceAll
Next
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
End With
End With
Application.ScreenUpdating = True
End Sub
You could, of course, add a line of code before the final 'End With' to save the document with a new name.
To select the entire paragraph, following the line
.Start = .Paragraphs.First.Range.Start
add
.End = .Paragraphs.First.Range.End
... then to match only whole words, after
.MatchWildcards = False
add
.MatchWholeWord = True
And to run the code for multiple words you should add a parameter to your Sub eg
Sub TestOne(theWord As String)
then replace
.Text = "see"
with
.Text = theWord
And to run your code for each required word, add a Sub such as
Sub RunMe()
TestOne "see"
TestOne "blacklist"
End Sub
... optionally, move your MsgBoxes into RunMe()
I'm trying to write a macro to change the case of "section 1", "section 2", etc. to title case, so they all read "Section 1" etc. I've adapted Variatus' very helpful code here:
Dim Rng As Range
Dim Fnd As Boolean
Set Rng = Selection.Range
With Rng.Find
.ClearFormatting
.Execute FindText:="section [0-9]", Forward:=True, _
Format:=False, Wrap:=wdFindContinue, MatchWildcards:=True
Fnd = .Found
End With
If Fnd = True Then
Rng.Case = wdNextCase
End If
The issue I'm having with this is that it only changes one instance at a time. Ideally it would change the case of all instances with one keypress.
As a bonus, I'd also like it to register the change of case as a tracked change. As I'm using tracked changes, I can't do a simple replace text macro with section ([0-9]) for Section \1, as the bug with tracked makes it "1Section ", "2Section ", etc. This isn't essential but would be a really nice bonus. The .Case function doesn't get tracked, and .Font only has an option for .AllCaps.
Perhaps there's a way it can find section [0-9], move the cursor to the beginning of the word and select the first letter, set .Font.AllCaps = True, and loop until there are no more instances of section [0-9]? Just an idea, but that's way beyond my macro ability at the moment. The main thing for now is getting the above code to apply to all instances of section [0-9].
Cheers!
Try:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "section [0-9]"
.Replacement.Text = ""
.Format = False
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
End With
Do While .Find.Execute
.Characters.First.Text = "S"
.Collapse wdCollapseEnd
Loop
End With
Application.ScreenUpdating = True
End Sub
In a long Word document I'd like to do the following:
Find all 'Heading 2' styles paragraphs, and IF those headings are not worded "Notes" then apply a certain style to the immediately following paragraph.
Here's my code:
Dim oPara As Paragraph
For Each oPara In ActiveDocument.Paragraphs
If oPara.Style = "Heading 2" And oPara.Range.Text <> "Notes" Then
oPara.Range.Next(Unit:=wdParagraph, Count:=1).Select
Selection.Style = "Normal"
End If
Next oPara
However, the paragraphs worded "Notes" are not excluded from the procedure so those following them also get converted to style "Normal". I'm not even sure oPara.Range.Text actually retrieves the wording of the paragraph.
Thank you.
I agree with Timothy. The following is faster still - and simpler. It's also more reliable, since Timothy's code matches on 'Notes' anywhere in the paragraph instead of 'Notes' being the whole of the paragraph text.
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Style = ActiveDocument.Styles(wdStyleHeading2)
.Forward = True
.Format = True
.Wrap = wdFindStop
End With
Do While .Find.Execute = True
If .Text <> "Notes" & vbCr Then .Next(wdParagraph, 1).Style = wdStyleNormal
.Collapse wdCollapseEnd
Loop
End With
Application.ScreenUpdating = True
End Sub
Try like this:
Dim oPara As Paragraph
For Each oPara In ActiveDocument.Paragraphs
If oPara.Style = "Heading 2" And Replace(oPara.Range.Text, Chr(13), "") <> "Notes" Then
oPara.Range.Next(Unit:=wdParagraph, Count:=1).Select
Selection.Style = "Normal"
End If
Next oPara
It seems that Word includes a carriage return Chr(13) after the header text, so when checking if the header text is "Notes", the carriage return must be removed.
The most efficient way of finding all the instances of 'Heading 2' is to use Find. You can then test the text of the found range and if it meets your criteria apply the style to the following paragraph.
Sub FormatAfterHeading()
Dim findRange As Range
Set findRange = ActiveDocument.Content
With findRange.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Style = ActiveDocument.Styles(wdStyleHeading2)
.Forward = True
.Format = True
.Wrap = wdFindStop
Do While .Execute = True
If InStr(findRange.Text, "Notes") > 0 Then
'do nothing
Else
findRange.Next(wdParagraph, 1).Style = wdStyleNormal
End If
findRange.Collapse wdCollapseEnd
Loop
End With
End Sub
I have a Find/Execute routine that looks for paragraphs in my custom style, Bullet_Type_1_Level_1, which is a custom bulleted list style, and processes the paragraphs. (It checks each paragraph in the given range to see if it terminates in a period or not, but that's not important for this question). The routine currently works fine, but I want to expand it to search for additional levels--which translates into additional styles--of my outline list and to search for a style in another list, too. Is there a compact way to have my code also look for paragraphs in Bullet_Type_1_Level_2 and numlist_Level_1 (and process them, too) while it's at it? Here's the guts of my existing code:
For Each para In RangeToCheck.Paragraphs
With Selection.Find
.Text = ""
.Style = "Bullet_Type_1_Level_1"
.Wrap = wdFindStop
.Execute
Do While .Found = True 'Look for the specified style
strSentence = Selection.Text
'Test the string using a block of code that I'm omitting, for brevity.
'Finally, depending on what happened, put or don't a period at the end of the original range.
End With
Next para
You can add another loop.
Declare i (or more meaningful variable name), and loop through that.
Dim i As Long
For Each para In RangeToCheck.Paragraphs
For i = 1 To 3
With Selection.Find
.Text = ""
Select Case i
Case 1
.Style = "Bullet_Type_1_Level_1"
Case 2
.Style = "Bullet_Type_1_Level_2"
Case 3
.Style = "numlist_Level_1"
End Select
.Wrap = wdFindStop
.Execute
Do While .Found = True 'Look for the specified style
strSentence = Selection.Text
'Test the string using a block of code that I'm omitting, for brevity.
'Finally, depending on what happened, put or don't a period at the end of the original range.
End With
Next i
Next para
Probably not the prettiest solution out there - word is not my strong point ☺.
An alternative approach that may be quicker if there are paragraphs that are none of those Styles:
Dim i As Long
For i = 1 To 3
With RangeToCheck
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Forward = True
.Format = True
.Wrap = wdFindStop
.Style = "Bullet_Type_1_Level_" & i
.Execute
End With
Do While .Find.Found = True
If .InRange(RangeToCheck) = False Then Exit Do
Select Case i
Case 1 'Do something for Bullet_Type_1_Level_1
Case 2 'Do something for Bullet_Type_1_Level_2
Case 3 'Do something for Bullet_Type_1_Level_3
End Select
If ActiveDocument.Range.End = RangeToCheck.Range.End Then Exit Do
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Next
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