I'm trying to remove all captions within a specific range (Page 4 until the end of the document).
I would like to remove only the hyperlink and not the text itself.
For example:
Some text here -> Some text here
after removing the hyperlink caption.
I tried:
Sub removeCaptions()
Dim rgePages As Range
Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=4
Set rgePages = Selection.Range
lastPage = ActiveDocument.ActiveWindow.Panes(1).Pages.Count
Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=lastPage
rgePages.End = Selection.Bookmarks("\Page").Range.End
With rgePages.Select
If Range.Style = "Caption" Then
Range.Delete
End If
End With
End Sub
I only get the range without removing the captions.
For example:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Format = True
.Forward = True
.Style = wdStyleCaption
.Wrap = wdFindStop
End With
Do While .Find.Execute
If .Information(wdActiveEndAdjustedPageNumber) > 3 Then .Fields.Unlink
.Collapse wdCollapseEnd
Loop
End With
Application.ScreenUpdating = True
End Sub
Related
my purpose is to find author and the year (four digit) inside parenthesis in a word document through regex or wildcards and format the color (change from black to red) to select them through select similar text
my sample to change italic and only all text inside parenthesis:
Dim Rng As Range
Dim n As Long
Application.ScreenUpdating = False
n = Selection.End
With Selection.Find
.MatchWildcards = True
.ClearFormatting
.Wrap = wdFindStop
.text = "\(*\)"
Do While .Execute
Set Rng = Selection.Range
If Rng.Start > n Then Exit Do
Rng.MoveStart unit:=wdCharacter, count:=1
Rng.MoveEnd unit:=wdCharacter, count:=-1
Rng.Font.Italic = True
Loop
End With
Application.ScreenUpdating = True
End Sub
The following code may point you in the right direction
Option Explicit
Sub Test()
SetAuthorTextColour WdColorIndex.wdRed
End Sub
Sub SetAuthorTextColour(ByVal ipColour As WdColorIndex)
Dim myText As Word.Range
With ActiveDocument.StoryRanges(wdMainTextStory)
Do
With .Find
.MatchWildcards = True
.Text = "([(])(*)([0123456789]{4,4})(*)([)])"
.ClearFormatting
.Format = True
.Wrap = wdFindStop
.Execute
End With
If .Find.Found Then
Set myText = .Duplicate
myText.MoveStart unit:=wdCharacter, Count:=1
myText.MoveEnd unit:=wdCharacter, Count:=-1
' you may wish to change to using colorindex as
' I think color is deprecated.
myText.Font.ColorIndex = ipColour
End If
Loop While .Find.Found
End With
End Sub
Sorry, I'm not comfortable with VBA code but, in my Word document (.docx) there are multiple highlight colors and, for example, I need to select all yellow highlights and hide them at one time.
I found this code, but it deletes all yellow highlights after have found them, while I only need them to be selected and hidden:
Sub Highlight()
Dim r As Range
Set r = ActiveDocument.Range
With r.Find
.Highlight = True
Do While .Execute(FindText:="", Forward:=True) = True
If r.HighlightColorIndex = wdYellow Then
r.HighlightColorIndex = wdAuto
r.Collapse 0
End If
Loop
End With
End Sub
Does someone have any idea to help me with this?
The code you found lacks some important checks. Try the following:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Format = False
.Forward = True
.Wrap = wdFindStop
.Highlight = True
End With
Do While .Find.Execute
If .HighlightColorIndex = wdYellow Then .Font.Hidden = True
'The next If ... End If block is needed in case the highlighted content is in a table and includes the end-of-cell marker or end-of-row marker
If .Information(wdWithInTable) = True Then
If .End = .Cells(1).Range.End - 1 Then
.End = .Cells(1).Range.End
.Collapse wdCollapseEnd
If .Information(wdAtEndOfRowMarker) = True Then
.End = .End + 1
End If
End If
End If
'The next line is needed in case the highlighted content includes the final paragraph break
If .End = ActiveDocument.Range.End Then Exit Do
.Collapse wdCollapseEnd
Loop
End With
Application.ScreenUpdating = True
End Sub
From a comparison docx file I need to extract into two word files the text formatted as strikethrough in one docx file and the text formatted as double underline in another docx file to be able to perform the wordcount of newly inserted and deleted text separately.
To do this, I wrote this macro, that actually activates the correct files, but only copies and pastes the formatting resulting from the first search.
Sub WSC_extraction_for_wordcount()
'This macro extracts double underlined text to the file "target_ins"
'This macro extracts strikethrough text to the file "target_del"
Application.ScreenUpdating = False
Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
'STRIKETHROUGH processing
Do
With Selection.Find.Font
.StrikeThrough = True 'Then
Selection.Find.Execute FindText:="", Forward:=True, Format:=True
Selection.Cut
Windows("target_del.docx").Activate
Selection.PasteAndFormat (wdPasteDefault)
Selection.TypeParagraph
Windows("source.docx").Activate
End With
'DOUBLE UNDERLINE processing
With Selection.Find.Font
.Underline = wdUnderlineDouble = True 'Then
Selection.Find.Execute FindText:="", Forward:=True, Wrap:=wdFindContinue, Format:=True
Selection.Cut
Windows("target_ins.docx").Activate
Selection.PasteAndFormat (wdPasteDefault)
Selection.TypeParagraph
Windows("source.docx").Activate
End With
Loop
End Sub
I would be grateful if someone could help me in transforming the options into something like: if the next sentence you encounter is formatted as strikethrough, copy it to file target_del, if the next sentence you encounter is formatted as double underlined, copy it to the file target_ins.
Thank you in advance!
The code below avoids the use of the Selection object. It also assumes that the documents the text is to be moved to are already open.
Sub WSC_extraction_for_wordcount()
'This macro extracts double underlined text to the file "target_ins"
'This macro extracts strikethrough text to the file "target_del"
Application.ScreenUpdating = False
Dim source As Document: Set source = ActiveDocument
Dim targetDel As Document: Set targetDel = Documents("target_del.docx")
Dim targetIns As Document: Set targetIns = Documents("target_ins.docx")
'STRIKETHROUGH processing
With source.Content
With .Find
.ClearFormatting
.Text = ""
.Replacement.ClearFormatting
.Text = ""
.Forward = True
.Format = True
.Wrap = wdFindStop
.Font.StrikeThrough = True
End With
Do While .Find.Execute
targetDel.Characters.Last.FormattedText = .FormattedText
targetDel.Characters.Last.InsertParagraphAfter
.Delete
Loop
End With
'DOUBLE UNDERLINE processing
With source.Content
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = True
.Font.Underline = wdUnderlineDouble
End With
Do While .Find.Execute
targetIns.Characters.Last.FormattedText = .FormattedText
targetIns.Characters.Last.InsertParagraphAfter
.Delete
Loop
End With
End Sub
Without the overhead of creating new documents:
Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, j As Long
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Font.Underline = wdUnderlineDouble
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
End With
Do While .Find.Execute
i = i + .ComputeStatistics(wdStatisticWords)
If .Information(wdWithInTable) = True Then
If .End = .Cells(1).Range.End - 1 Then
.End = .Cells(1).Range.End
.Collapse wdCollapseEnd
If .Information(wdAtEndOfRowMarker) = True Then
.End = .End + 1
End If
End If
End If
If .End = ActiveDocument.Range.End Then Exit Do
.Collapse wdCollapseEnd
Loop
End With
With ActiveDocument.Range
With .Find
.ClearFormatting
.Font.StrikeThrough = True
.Forward = True
.Wrap = wdFindStop
End With
Do While .Find.Execute
j = j + .ComputeStatistics(wdStatisticWords)
If .Information(wdWithInTable) = True Then
If .End = .Cells(1).Range.End - 1 Then
.End = .Cells(1).Range.End
.Collapse wdCollapseEnd
If .Information(wdAtEndOfRowMarker) = True Then
.End = .End + 1
End If
End If
End If
If .End = ActiveDocument.Range.End Then Exit Do
.Collapse wdCollapseEnd
Loop
End With
Application.ScreenUpdating = True
MsgBox i & " words added." & vbCr & j & " words deleted."
End Sub
I would like to apply a character style ("Bold Italics") to the first two words of all paragraphs set in the "3 Species" style in MS Word (and later, I'd also like another macro to do same for all the words after the second tab in a different style). I know how to do all this in InDesign, but I'd like it set up in the original Word documents before they get flowed into InDesign.
I'm new at this and can't figure out how to apply it to only the first two words. I did get it to apply the character style to the whole paragraph or to a specific word in that style. It seems like it ought to be simple, but I've only learned to use find and replace type functions so far, and I imagine I will have to use the Range functions, which I don't understand yet. Thanks for any help!
Sub Add_Character_Style()
'
' Add_Character_Style Macro
'
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Style = "3 Species"
.Text = ""
.Replacement.Text = ""
.Replacement.Style = "Bold Italics"
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
For example:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "<*>[,. ^s^t]#<*>"
.Style = "3 Species"
.Replacement.Text = ""
.Format = True
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
End With
Do While .Find.Execute
.Style = "Bold Italics"
.Start = .Paragraphs(1).Range.End
Loop
End With
Application.ScreenUpdating = True
End Sub
Try this:
Sub Add_Character_Style()
Dim p As Paragraph
Dim doc As Document: Set doc = ActiveDocument
For Each p In doc.Paragraphs
p.Range.Select
Selection.Collapse Direction:=wdCollapseStart
Selection.MoveRight Unit:=wdWord, Count:=2, Extend:=wdExtend
With Selection
If .Style = "3 Species" Then .Style = "Bold Italic"
End With
Next p
End Sub
EDIT:
To avoid use of the Selection object (Timothy Rylatt)
Sub Add_Character_Style()
Dim p As Paragraph
Dim doc As Document: Set doc = ActiveDocument
Dim rng As Range
For Each p In doc.Paragraphs
If p.Range.Style = "3 Species" Then
Set rng = p.Range
With rng
.Collapse Direction:=wdCollapseStart
.MoveEnd Unit:=wdWord, Count:=2
.Style = "Bold Italics"
End With
End If
Next p
End Sub
FURTHER EDIT per macropod:
Sub Add_Character_Style()
Application.ScreenUpdating = False
Dim Para As Paragraph, Rng As Range
For Each Para In ActiveDocument.Paragraphs
With Para
If .Style = "3 Species" Then
If .Range.ComputeStatistics(wdStatisticWords) > 1 Then
Set Rng = .Range.Words.First
With Rng
Do While .ComputeStatistics(wdStatisticWords) < 2
.MoveEnd wdWord, 1
Loop
.Style = "Bold Italic"
End With
End If
End If
End With
Next
Application.ScreenUpdating = True
End Sub
I have a VBA macro(Word2010) script to highlight all the text in italics. But when executed in large file say a document with more than 10 pages the Word get crashed.
I have used the below code for this purpose.
Sub Italics_Highlight()
'
' test_italics_highlight_ Macro
'
'
Application.ScreenUpdating = False
Dim myString As Word.Range
Set myString = ActiveDocument.Content
With myString.Find
.ClearFormatting
.Text = ""
.Font.Italic = True
While .Execute
myString.HighlightColorIndex = wdTurquoise
myString.Collapse wdCollapseEnd
Wend
End With
MsgBox "Thank you!"
End Sub
Could you please help to overcome this. Thanks for your help in advance.
Your error description looks like your code is running forever and doesn't finish.
You might want to add a DoEvents inside your While loop to keep Word responsive while running the code.
With myString.Find
.ClearFormatting
.Text = ""
.Font.Italic = True
While .Execute
DoEvents 'keeps Word responsive
myString.HighlightColorIndex = wdTurquoise
myString.Collapse wdCollapseEnd
Wend
End With
I'm not sure if your code will ever stop. The loop might not stop at the end of the document but start again from beginning, and therefore always find something italic again and again, looping forever.
So you might need to set the .Wrap = wdFindStop to stop at the end of the document.
See Find.Wrap Property (Word).
With myString.Find
.ClearFormatting
.Text = ""
.Font.Italic = True
.Wrap = wdFindStop 'stop at the end of the document
While .Execute
DoEvents 'keeps Word responsive
myString.HighlightColorIndex = wdTurquoise
myString.Collapse wdCollapseEnd
Wend
End With
You don't need to stop at each "found" and apply highlighting. You can do it as part of a Find/Replace:
Sub testInfiniteLoop()
Dim myString As word.Range
Set myString = ActiveDocument.content
Options.DefaultHighlightColorIndex = wdTurquoise
With myString.Find
.ClearFormatting
.Text = ""
.Font.Italic = True
.Replacement.Text = ""
.Replacement.Highlight = wdTurquoise
.wrap = wdFindStop 'stop at the end of the document
.Execute Replace:=wdReplaceAll
End With
End Sub
The following code not only highlights but also restores whatever highlight settings were previously in force:
Sub Italics_Highlight()
Application.ScreenUpdating = False
Dim i As Long: i = Options.DefaultHighlightColorIndex
Options.DefaultHighlightColorIndex = wdTurquoise
With ActiveDocument.Content.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = "^&"
.Replacement.Highlight = True
.Format = True
.Font.Italic = True
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Options.DefaultHighlightColorIndex = i
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
As you can see, you also don't need:
Dim myString As Word.Range
Set myString = ActiveDocument.Content