I have the following code that searches for a certain point in a document and creates a search range until the end of the document. Then within that range it removes the paragraph following entirely bold paragraphs (subheadings), ignoring any styles that aren't Normal and aren't in a table. However, it seems to search the entire document (i.e. the beginning as well). How can I make it only search the range (i.e. from where I've positioned the cursor down to the end of the document)?
Dim aPara As Paragraph
Dim oSearchRange As Range
With Selection.Find
.Text = "Dear "
End With
Selection.MoveDown Unit:=wdParagraph, Count:=4
Set oSearchRange = Selection.Range
oSearchRange.End = ActiveDocument.Content.End
oSearchRange.MoveEnd wdParagraph, -1
For Each aPara In oSearchRange.Paragraphs
If aPara.Range.Font.Bold = True And aPara.Range.Next.Style = ActiveDocument.Styles("Normal") And Not aPara.Range.Next.Information(wdWithInTable) Then aPara.Range.Next.Delete
Next aPara
Thanks
I needed to add .Execute after the "Dear " search, thanks to Teamothy (:
Related
I'm stuck with this problem for the past two days and I can't find a way to overcome it.
I've a document (400 pages) where I want to replace ALL the uppercase words to SmallCaps AND set the text as "title sentence".
When I register a macro, I found the commands that I need:
Selection.Range.Case = wdTitleSentence
Selection.Font.SmallCaps = wdToggle
The problem is that I can't find a way to apply these commands only to the uppercase words and NOT to the selected text.
You could try using a wildcard search, though you'll need to be careful how you specify it other wise you could change every capital letter in the document to small caps.
Sub ConvertUpperCase()
Dim findRange As Range
Set findRange = ActiveDocument.Content
With findRange.Find
.ClearFormatting
'find at least two consecutive capital letters
.Text = "[A-Z]{2,}"
.MatchWildcards = True
Do While .Execute = True
With findRange
.Case = wdTitleSentence
.Font.SmallCaps = True
.Collapse wdCollapseEnd
End With
Loop
End With
End Sub
I want to have bold and not bold text in one line.
With objWrdDoc
.Styles.Add ("S2")
.Styles.Add ("S3")
.Styles("S2").Font.Bold = True
.Styles("S3").Font.Bold = False
End With
With objWrdApp.Selection
.TypeParagraph
.Style = objWrdDoc.Styles("S2")
.TypeText Text:="I want to have bold "
.Style = objWrdDoc.Styles("S3")
.TypeText Text:="and not bold text in one line."
End With
As a result, the entire text is not bold.
While working with the Selection object feels "intuitive", it's not as accurate for writing code to manipulate Word as using Range objects. You can think about a Range as being an invisible selection, with the important differences that
code can work with multiple Range objects
the user can't affect where a Range is (clicking on the screen or pressing arrow keys changes a Selection)
tracking where a Range is at any given point in the code is reliable
Changing the code in the question to work with a "target" Range could look as follows.
(Note that I've also added Style objects for the styles being defined. It's much more reliable and a lot less typing to work with objects, rather than constructs such as objWrdDoc.Styles("S3").)
Dim S2 as Word.Style, S3 as Word.Style 'As Object if using late-binding
With objWrdDoc
Set S2 = .Styles.Add("S2")
Set S3 = .Styles.Add("S3")
S2.Font.Bold = True
S3.Font.Bold = False
End With
Dim objRange as Word.Range 'As Object if using late-binding
Set objRange = objWrdApp.Selection.Range
With objRange
.Text = vbCr 'Chr(13) = paragraph mark
'The new text should follow the inserted paragraph mark
'Like pressing right-arrow to "collapse" a selection
.Collapse wdCollapseEnd
'When working with ranges, apply the formatting after writing the text
.Text = "I want to have bold "
.Style = S2
.Collapse wdCollapseEnd
.Text = "and not bold text in one line."
.Style = S3
End With
This is a follow-up question to my question (How to search/find for multiple format styles in VBA for Word?). This time instead of inserting a text to the beginning of each heading, we want to remove a few characters from the start of each heading after navigating to a heading titled 'Appendix'.
Trying to get rid of the first number along with the following white space or a period for multi-style paragraphs. For example, we would have headings with '4 Appendix A', '5.1 Intro', '10.2.3 Glossary...', which would be renamed to 'Appendix A', '1 Intro', '2.3 Glossary...'.
I removed the Selection.TypeText Text:=" *Test* " Selection.MoveStart wdParagraph, 1 lines after navigating to the Appendix section and replaced Selection.TypeText Text:=" *Test* " in the If found Then statement with the code seen below.
`If found Then
Selection.HomeKey Unit:=wdLine
If IsNumeric(Selection.Characters(2) = True) Then
Selection.Delete Unit:=wdCharacter, Count:=3
Selection.MoveStart wdParagraph, 1
ElseIf IsNumeric(Selection.Characters(1) = True) Then
Selection.Delete Unit:=wdCharacter, Count:=2
Selection.MoveStart wdParagraph, 1
Else
Selection.MoveStart wdParagraph, 1
End If
End If`
Getting run-time error '5941' - The requested member of the collection does not exist. If IsNumeric(Selection.Characters(2) = True) Then seems to be the cause of the error. If I change the '2' to a '1' and Count:=3 to Count:=2 in the If statement and '1' to a '2' and Count:=2 to Count:=3 in theElseIf, then the code is executable. This is a problem because it doesn't recognize theElseIf` and only deletes 2 characters for a double-digit number leaving an unwanted white-space or period, i.e., '.2.3 Glossary...' or ' Appendix G'.
The reason for the error 5941 due to Characters(2). This is not doing what you imagine. That gets the second character, only, from the selection, not two characters. And the selection is a blinking insertion point so does not contain two characters. The error says: You're telling me to get the second character, but there aren't two characters, so I can't give you what you require.
Another problem in that line (that you're not seeing, yet): The parenthesis should be before the =, not after the True: If IsNumeric(Selection.Characters(2)) = True.
Since it's necessary to test multiple characters, the selection (or Range) needs to be extended. Word VBA offers a number of "Move" methods; the equivalent to holding Shift and pressing right-arrow on the keyboard is MoveEnd, and there are variations of this such as MoveEndWhile and MoveEndUntil that allow you to specify conditions. Optionally, these can return the number of characters that were moved (as done in the code below).
The following approach uses MoveEndWhile to first get numeric characters (until the next is no longer numeric): MoveEndWhile("0123456789", wdForward)... Followed by extending until the next character is no longer a ..
This Range is then deleted. (There's also a Debug.Print line in there to print out the content of the Range and the number of characters moved, in case that information interests you - just remove the comment mark ').
Note that I've included the entire code, in case others are interested in seeing it in its entirety. The parts from the previous question that are no longer relevant have been removed. You'll find the new part marked as '''NEW CODE HERE.
Sub AppendixFix()
' Declaring variables
Dim multiStyles As String, i As Integer
Dim aStyleList As Variant
Dim counter As Long, s As String, found As Boolean
Dim rngStart As Range
multiStyles = "Heading 1,Heading 2,Heading 3,Heading 4,Heading 5,Heading 6,Heading 7,Heading 8,Heading 9"
aStyleList = Split(multiStyles, ",")
' Start at the top of document and clear find formatting
Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
' Navigate to Appendix section
Selection.Find.style = ActiveDocument.styles("Heading 1")
With Selection.Find
.Text = "Appendix"
.Forward = True
.wrap = wdFindStop
.Format = True
.Execute
End With
Selection.HomeKey Unit:=wdLine
Set rngStart = Selection.Range.Duplicate
' Loop through all the styles in the list
For counter = LBound(aStyleList) To UBound(aStyleList)
'Loop as long as the style is found
Do
s = aStyleList(counter)
With Selection.Find
.style = ActiveDocument.styles(s)
.Text = "^p"
.Forward = True
.wrap = wdFindStop
.Format = True
found = .Execute
End With
'''NEW CODE HERE
Dim rngStartOfLine As Range
Dim charsMovedNumeric As Long, charsMovedDot
If found Then
Selection.HomeKey Unit:=wdLine
Set rngStartOfLine = Selection.Range
charsMovedNumeric = rngStartOfLine.MoveEndWhile("0123456789", wdForward)
charsMovedDot = rngStartOfLine.MoveEndWhile(".")
'Debug.Print rngStartOfLine, charsMovedNumeric, charsMovedDot
rngStartOfLine.Delete
Selection.MoveStart wdParagraph, 1
End If
'''END OF NEW CODE
If Selection.Start = ActiveDocument.content.End - 1 Then
'End of Document, then loop to next style in list
Exit For
End If
Loop Until found = False
'start back at the Appendix for the next style
rngStart.Select
Next
End Sub
I have a word document that is 180 pages and uses all the highlight Colors randomly throughout the document. The document has several different formats on it from italics, bullets and underline and different size fonts.
What I am trying to do is filter through the document select all paragraphs that contain a certain color highlight then paste it in a new document keeping all formatting in place. It then loops through again and selects the next color highlight and pastes it in the same new document with a page break in between or just a new document all together. I have been trying to figure this out for 2 days.
I have tried the formulas from this Word VBA copy highlighted text to new document and preserve formatting and other ones on Stack Overflow but none of them preserve all the formatting or one that I found I could only get it to copy the whole document with formatting and paste in but not the selected highlights.
This one does the trick but it removes all formatting and can't figure out how to place page break in.
Sub ExtractHighlightedTextsInSameColor()
Dim objDoc As Document, objDocAdd As Document
Dim objRange As Range
Dim strFindColor As String
Dim highliteColor As Variant
highliteColor = Array(wdYellow, wdTeal)
Set objDoc = ActiveDocument
Set objDocAdd = Documents.Add
objDoc.Activate
For i = LBound(highliteColor) To UBound(highliteColor)
With Selection
.HomeKey Unit:=wdStory
With Selection.Find
.Highlight = True
Do While .Execute
If Selection.Range.HighlightColorIndex = highliteColor(i) Then
Set objRange = Selection.Range
objDocAdd.Range.InsertAfter objRange & vbCr
Selection.Collapse wdCollapseEnd
End If
Loop
End With
End With
Next
End Sub
'This one only copies all text in document and not just highliteColor asked for
Sub HighlightedColor()
Dim objDoc As Document, objDocAdd As Document
Dim objRange As Range
Dim highliteColor As Variant
highliteColor = Array(wdYellow, wdTeal, wdPink)
Set objDoc = ActiveDocument
Set objDocAdd = Documents.Add
objDoc.Activate
For i = LBound(highliteColor) To UBound(highliteColor)
With Selection
.HomeKey Unit:=wdStory
With Selection.Find
.Highlight = True
Do While .Execute
If Selection.Range.HighlightColorIndex = highliteColor(i) Then
Set objRange = Selection.Range.FormattedText
objRange.Collapse wdCollapseEnd
objDocAdd.Content.FormattedText = objRange
End If
Loop
End With
End With
Next
End Sub
I expect the output to copy all text that are a certain highlight color, paste them into a new document preserving all formatting and then page break it. Go back select the next highlight color and paste in document until all colors are gotten.
I've made adjustments to your code based on what I understand you want to do. In some cases I tried to make it a little more readable, for example I removed one of the With methods.
Look closely at the use of FormattedText and how it is transferred from one range to another. And also look at the end of the routine for how a page break is inserted.
Sub ExtractHighlightedTextsInSameColor()
Dim objDoc As Document, objDocAdd As Document
Dim objRange As Range
Dim strFindColor As String
Dim highliteColor As Variant
Dim i As Long
highliteColor = Array(wdYellow, wdTeal)
Set objDoc = ActiveDocument
Set objDocAdd = Documents.Add
Set objRange = objDocAdd.Content
For i = LBound(highliteColor) To UBound(highliteColor)
objDoc.Activate
Selection.HomeKey unit:=wdStory
objRange.Collapse wdCollapseEnd
With Selection.Find
.ClearFormatting
.Forward = True
.Format = True
.Highlight = True
.Wrap = wdFindStop
.Execute
Do While .found
If Selection.Range.HighlightColorIndex = highliteColor(i) Then
' the following copies only the highlighted text
' objRange.FormattedText = Selection.Range.FormattedText
'if you want the entire paragraph that contains a highlighted text item then use this
objRange.FormattedText = Selection.Range.Paragraphs(1).Range.FormattedText
Selection.Collapse wdCollapseEnd
objRange.InsertParagraphAfter
objRange.Collapse wdCollapseEnd
Else
objRange.Collapse wdCollapseEnd
End If
.Execute
Loop
End With
objRange.Collapse wdCollapseEnd
If i < UBound(highliteColor) Then
'added a conditional check so an extra page break is not inserted at end of document
objRange.InsertBreak Word.WdBreakType.wdPageBreak
End If
Next
End Sub
I'm working on a Powerpoint slide, where I few texts are listed. I have to search for these texts in a Word Document which has a lot of Headings and Texts. After I find the title text, I need to copy the text under the Heading and paste in a new document.
Basically, the VBA coding has to be done in the Powerpoint VBA, with two documents in the background for searching text and pasting it in another.
I've opened the word doc. But searching the text in it and selecting it for copying to another document is what I've not been able to do. Kindly help me.
I see. The following is not exactly elegant since it uses Selection which I always try to avoid but it is the only way I know to achieve such a thing.
Disclaimer 1: this is made in Word VBA, so you will need a slight adaption, like set a reference to Word, use a wrdApp = New Word.Application object and declare doc and newdoc explicitely as Word.Document.
Disclaimer 2: Since you search for text instead of the respective heading, beware that this will find the first occurence of that text so you better not have the same text in several chapters. ;-)
Disclaimer 3: I cannot paste anymore! :-( My clipboard is set, it pastes elsewhere but I just cannot paste in here.
Code follows with first edit, hopefully in a minute...
Edit: yepp, pasting works again. :-)
Sub FindChapter()
Dim doc As Document, newdoc As Document
Dim startrange As Long, endrange As Long
Dim HeadingToFind As String, ChapterToFind As String
ChapterToFind = "zgasfdiukzfdggsdaf" 'just for testing
Set doc = ActiveDocument
Set newdoc = Documents.Add
doc.Activate
Selection.HomeKey unit:=wdStory
With Selection
With .Find
.ClearFormatting
.Text = ChapterToFind
.MatchWildcards = False
.MatchCase = True
.Execute
End With
If .Find.Found Then
'**********
'Find preceding heading to know where chapter starts
'**********
.Collapse wdCollapseStart
With .Find
.Text = ""
.Style = "Heading 1"
.Forward = False
.Execute
If Not .Found Then
MsgBox "Could not find chapter heading"
Exit Sub
End If
End With
.MoveDown Count:=1
.HomeKey unit:=wdLine
startrange = .Start
'*********
'Find next heading to know where chapter ends
'*********
.Find.Forward = True
.Find.Execute
.Collapse wdCollapseStart
.MoveUp Count:=1
.EndKey unit:=wdLine
endrange = .End
doc.Range(startrange, endrange).Copy
newdoc.Content.Paste
newdoc.SaveAs2 doc.Path & "\" & HeadingToFind & ".docx", wdFormatFlatXML
Else
MsgBox "Chapter not found"
End If
End With
End Sub
Edit: If you need to search for a "feature" that will be in some table in column 1 with the description in column 2 and you need that description in a new doc, try this:
Sub FindFeature()
Dim doc As Document, newdoc As Document
Dim FeatureToFind As String
Dim ro As Long, tbl As Table
FeatureToFind = "zgasfdiukzfdggsdaf" 'just for testing
Set doc = ActiveDocument
Set newdoc = Documents.Add
doc.Activate
Selection.HomeKey unit:=wdStory
With Selection
With .Find
.ClearFormatting
.Text = FeatureToFind
.MatchWildcards = False
.MatchCase = True
.Execute
End With
If .Find.Found Then
Set tbl = Selection.Tables(1)
ro = Selection.Cells(1).RowIndex
tbl.Cell(ro, 2).Range.Copy
newdoc.Range.Paste
End If
End With
End Sub
Edit: Slight adaptation so you can paste without overwriting existing content in newdoc:
Instead of newdoc.Range.Paste just use something along the line of this:
Dim ran As Range
Set ran = newdoc.Range
ran.Start = ran.End
ran.Paste