I have the code below without using Selection.
Sub Format paragraph()
Dim wdDoc As Document
With wdDoc.Range.Find
.Font.Size = 12
.Text = "?"
.Execute
End With
End Sub
When the character with font size = 12 is found, how can I change the format of the current paragraph? for example:
wdDoc.Paragraph(current).Font.Size = 14
wdDoc.Paragraph(current).Font.Color = wdBlue
Thanks for any help.
The trick is to work with a specific Range object, which can be used to access its "parent" paragraph. When Find.Execute is successful, the Range being searched contains the found item (same as the selection jumps to the found item). For example:
Sub Format paragraph()
Dim rng as Range, para as Paragraph
Dim wdDoc As Document
Set wdDoc = ActiveDocument. 'Missing in code in question...
Set rng = wdDoc.Content 'Content returns the Range
With rng.Find
.Font.Size = 12
.Text = "?"
If .Execute = True Then
Set para = rng.Paragraphs(1)
para.Font.Size = 14
para.Font.Color = wdBlue
End If
End With
End Sub
Related
I have the code helps me find multiple texts. I want to do the following thing but i get stucked:
Select the entire row of found item
Copy the selected row to new table
Thanks
Sub FindMultiItemsInDoc()
Dim objListDoc As Document
Dim objTargetDoc As Document
Dim objParaRange As Range, objFoundRange As Range
Dim objParagraph As Paragraph
Dim strFileName As String
strFileName = InputBox("Enter the full name of the list document here:")
Set objTargetDoc = ActiveDocument
Set objListDoc = Documents.Open(strFileName)
objTargetDoc.Activate
For Each objParagraph In objListDoc.Paragraphs
Set objParaRange = objParagraph.Range
objParaRange.End = objParaRange.End - 1
With Selection
.HomeKey Unit:=wdStory
' Find target items.
With Selection.Find
.ClearFormatting
.Text = objParaRange
.MatchWholeWord = True
.MatchCase = False
.Execute
End With
Next objParagraph
End Sub
I use Word documents which are highlighted in a number of colors. What I need is for the VBA to find a highlighted section and paste that text in a new document, find the next highlighted section in a different color and copy that text in a new (different) document). My code does that for all 15 colors available for highlighting in Word. However, even if the color is not present in the text, it will create a new document for that color. So every time I run my code, I get 15 new documents.
I need the code to ignore a highlight color if that color is not present, while still creating new (and different) documents for the colors that are present in the document.
For example, I might get a document that only has highlighted text in blue and green, so I would need two new documents for that. Or I might get a document that has highlighted text in blue, green, yellow and red, so I would need four new focuments, one for each color.
Any ideas on what I need to change?
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, wdBlack, wdBlue, wdBrightGreen, wdDarkBlue, wdDarkRed, wdDarkYellow, wdGreen, wdPink, wdRed, wdTeal, wdTurquoise, wdViolet, wdWhite)
Set objDoc = ActiveDocument
For i = LBound(highliteColor) To UBound(highliteColor)
Set objDocAdd = Documents.Add
Set objRange = objDocAdd.Content
objRange.Collapse wdCollapseEnd
objDoc.Activate
Selection.HomeKey unit:=wdStory
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 wdCollapseEndwdYellow
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 think this is easier to manage if you split your code up a bit: first collect all of the highlighted ranges, and then process them.
This should be pretty close.
Sub TestDoc()
Dim col As Collection, rng As Range, dict As Object, hc As String
Dim doc As Document, destRng As Range
Set dict = CreateObject("scripting.dictionary") 'for tracking documents vs highlight colors
Set col = HighlightedRanges(ActiveDocument) 'first get all highlighted ranges
For Each rng In col
hc = CStr(rng.HighlightColorInde 'get the highlight color
If Not dict.Exists(hc) Then 'need a new doc for this one?
dict.Add hc, Documents.Add 'add doc and key to highlight color
End If
Set doc = dict(hc) 'get doc for this color
Set destRng = doc.Content 'copy the content over...
destRng.Collapse Direction:=wdCollapseEnd
destRng.InsertParagraphAfter
destRng.Collapse Direction:=wdCollapseEnd
destRng.FormattedText = rng.FormattedText
Next rng
End Sub
'return a collection of all highlighted ranges in `doc`
Function HighlightedRanges(doc As Document) As Collection
Dim rng As Range, col As New Collection
Set rng = doc.Content
With rng.Find
.ClearFormatting
.Forward = True
.Format = True
.Highlight = True
.Wrap = wdFindStop
Do While .Execute
col.Add doc.Range(rng.Start, rng.End) 'clone the range
Loop
End With
Set HighlightedRanges = col 'return all the found ranges
End Function
I am trying to create a macro that finds all text formulas and replaces it with OMath formulas.
I create a text, where all formulas are surrounded with special tags (in my case its word "formula"). Then I find all cases with regex and create variable that contains found formula. Then I give this variable to find method to create range, which I then modify.
Some formulas contain special characters (in my case its caret (^), which is used to create power) and find method doesn't select them.
How can I ignore special characters in variable that I give to find method?
Macro that I created:
Dim regexObject As Object
Set regexObject = CreateObject("VBScript.RegExp")
Dim matches As Object
Dim objEq As OMath
Dim objRange As Range
Dim match As Object
regexObject.Pattern = "formula(.*?)formula"
regexObject.MultiLine = True
Selection.WholeStory
While regexObject.test(Selection.Text)
Set matches = regexObject.Execute(Selection.Text)
For Each match In matches
MsgBox match
With Selection.Find
.Text = match
.MatchWildcards = False
.Execute
Set objRange = Selection.Range
objRange.Text = Mid(match, 8, Len(match) - 14)
Set objRange = Selection.OMaths.Add(objRange)
Set objEq = objRange.OMaths(1)
objEq.BuildUp
End With
Selection.WholeStory
Next
Wend
Sample Text:
formulaΨ=1,67∙0,72∙0,9∙1=1,09.formula
formulac_c=0,9formula
formulaE_q=Ψ WV_n^2/2,formula
formulac_m, c_e, c_c, c_sformula
For example:
Sub FindFormulaeCreateOMath()
Dim objEq As OMath
Dim findRange As Range
Dim eqRange As Range
Set findRange = ActiveDocument.Content
With findRange
With .Find
.Text = "formula*formula"
.MatchWildcards = True
End With
Do While .Find.Execute
.Text = Mid(.Text, 8, Len(.Text) - 14)
Set eqRange = findRange.OMaths.Add(.Duplicate)
Set objEq = eqRange.OMaths(1)
objEq.BuildUp
.Collapse wdCollapseEnd
Loop
End With
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 have a word document (report) and in that document, I'm importing many text files with fields like this:
{INCLUDETEXT "C:\\PATH\\TOXMLFILES\\Request.xml" \*CHARFORMAT}
Also I'm updating all those fields with a macro on opening the document...
Sub AutoOpen()
With Options
.UpdateFieldsAtPrint = True
.UpdateLinksAtPrint = True
End With
ActiveDocument.Fields.Update
End Sub
Now I need to highlight the text of those imported XMLs (in the IncludeText fields) between <faultstring></faultstring> tags
Here is code I got here on stackoverflow for highlighting text (making it bold)
Sub BoldBetweenQuotes()
' base for a quotes finding macro
Dim blnSearchAgain As Boolean
Dim blnFindStart As Boolean
Dim blnFindEnd As Boolean
Dim rngFind As word.Range
Dim rngFindStart As word.Range
Dim rngFindEnd As word.Range
Set rngFind = ActiveDocument.content
Set rngFindStart = rngFind.Duplicate
Do
' set up find of first of quote pair
With rngFindStart.Find
.ClearFormatting
.Text = "<faultstring>"
.Replacement.Text = ""
.Forward = True
.wrap = wdFindStop
blnFindStart = .Execute
End With
If blnFindStart Then
rngFindStart.Collapse wdCollapseEnd
Set rngFindEnd = rngFindStart.Duplicate
rngFindEnd.Find.Text = "</faultstring>"
blnFindEnd = rngFindEnd.Find.Execute
If blnFindEnd Then
rngFindStart.End = rngFindEnd.Start
' make it bold
rngFindStart.Font.Bold = True
rngFindStart.Start = rngFindEnd.End
rngFindStart.End = rngFind.End
blnSearchAgain = True
Else
blnSearchAgain = False
End If
Else
blnSearchAgain = False
End If
Loop While blnSearchAgain = True
End Sub
Problem is, when I run the macro in my Word document (with the IncludeText fields) it keeps cycling and bolding just the first appearance of text between faultstring tags. When I run it in a new Word document with some random text and faultrstring tags it works well...
EDIT: It turns out the problem is due to the faultstring tags being inside the IncludeText fields. I need to turn the fields into static text after opening the document and updating the fields. How can I do that?
In order to convert dynamic field content to static text using Word's object model (such as VBA) the Fields.Unlink method is required. For the entire document:
ActiveDocument.Fields.Unlink
This is also possible for any given Range; to remove the fields in the last paragraph, for example:
ActiveDocument.Paragraphs.Last.Range.Fields.Unlink
In order to unlink only a certain type of field, loop the Fields collection, test the Field.Type and unlink accordingly. For example, for IncludeText:
Sub DeleteIncludeTextFields()
Dim doc As word.Document
Set doc = ActiveDocument
Debug.Print DeleteFieldType(wdFieldIncludeText, doc)
End Sub
Function DeleteFieldType(fldType As word.WdFieldType, doc As word.Document) _
As Long
Dim fld As word.Field
Dim counter As Long
counter = 0
For Each fld In doc.Fields
If fld.Type = wdFieldIncludeText Then
fld.Unlink
counter = counter + 1
End If
Next
DeleteFieldType = counter
End Function
Assuming you want to do this for all the fields in your document, after updating it:
Sub AutoOpen()
With Options
.UpdateFieldsAtPrint = True
.UpdateLinksAtPrint = True
End With
ActiveDocument.Fields.Update
ActiveDocument.Fields.Unlink
End Sub