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
Related
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 have a hundreds of word documents that have multiple tables. Each table row has a specific custom style that was applied that identifies the data that goes in the cell. The need is to iterate through the word document, find the style, and add a ContentControl on that item. The issue that I have is the Selection.Find command restarts at the beginning of the document, so it ends up nesting ContentControls. I have tried adding in some counting mechanism, but while it fixes most of the issues, it leaves off at least some of the ContentControls and does have a few nests. I have tried only searching on a specific table but the Selection.Find overrides the selected table. Is there a way to iterate from the beginning of the document to the end so that I can dynamically add the content controls? Each document has 2 different types of tables. There will be only 1 of the following tables:
There can be 1 to 100 of this table:
The contentControl is supposed to encapsulate the data in the Document Level Metadata column. Here is the code I have up to this point
Option Explicit
Sub FindStyleReplaceWithCC()
Dim CCtrl As ContentControl
Do While ActiveDocument.ContentControls.Count > 0
For Each CCtrl In ActiveDocument.ContentControls
If CCtrl.LockContentControl = True Then CCtrl.LockContentControl = False
CCtrl.Delete False
Next
Loop
'For Each CCtrl In ActiveDocument.ContentControls
'For Each CCtrl In ActiveDocument.ContentControls
' MsgBox (CCtrl.Range)
'Next
'Dim CCtrl As ContentControl
Dim sty As Style
Dim oTbl As Table
''''''''''''''''''''''''''''''''''''''''
'Table 1
Dim thearray(1 To 13, 1 To 2)
Dim element As Variant
Dim arrWsNames() As Variant
Dim I As Integer
arrWsNames = Array("Sensitive Information Protection", "Applies To", "Functional Org", "Functional Process Owner", _
"Topic Owner", "Subject Matter Experts", "Author", "Corporate Source ID", "Superior Source", "CIPS Legacy Document", _
"Meta-Roles(DocLvl)", "SME Reviewer", "SourceDocs")
For I = 1 To 13
thearray(I, 1) = arrWsNames(I - 1)
thearray(I, 2) = 0
Next
Dim howmany As Integer
howmany = 0
For Each element In arrWsNames
Dim iterations As Integer
With Selection.Find
.ClearFormatting
.Style = ActiveDocument.Styles(element)
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Forward = False
.Wrap = wdFindContinue
End With
Selection.Find.Execute
Selection.Range.ContentControls.Add (wdContentControlRichText)
Selection.ParentContentControl.Title = element
Next
'''''''''''''''''''''''''''''''''''''
'Table 2
Dim thearray2(1 To 8, 1 To 2)
Dim arrWsNames2() As Variant
arrWsNames2 = Array("Meta-ReqType", "Meta-Roles", "Meta-Input", "Meta-Output", "Meta-Toolset", _
"Meta-Sources", "Meta-Traced", "Meta-Objective_Evidence")
For I = 1 To 8
thearray2(I, 1) = arrWsNames2(I - 1)
thearray2(I, 2) = 0
Next
howmany = 0
For Each element In arrWsNames2
iterations = 1
For Each oTbl In ActiveDocument.Tables
oTbl.Select
With Selection.Find
.ClearFormatting
.Style = ActiveDocument.Styles(element)
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Forward = False
.Wrap = wdFindContinue
End With
Selection.Find.Execute
If howmany + 1 = iterations Then
Selection.Range.ContentControls.Add (wdContentControlRichText)
Selection.ParentContentControl.Title = element
howmany = howmany + 1
iterations = iterations - 1
Else
iterations = iterations + 1
End If
Next
Next
MsgBox ("Done")
End Sub
If this can't be done in VBA, can it be done in .net?
This can definitely be done in VBA.
The first thing you need to do is to stop using the Selection object. Although there are occasions when Selection has to be used most things can be accomplished by using Range instead.
The next thing I recommend is breaking your code down into separate routines that only perform one element of the solution. This will not only enable you to simplify your code it will result in reusable routines.
I have edited your code as below and tested it in O365 on a document with a subset or your styles.
Sub AddContentControlsForMetadata()
RemoveContentControls ActiveDocument
Dim element As Variant
Dim arrWsNames() As Variant
arrWsNames = Array("Sensitive Information Protection", "Applies To", "Functional Org", "Functional Process Owner", _
"Topic Owner", "Subject Matter Experts", "Author", "Corporate Source ID", "Superior Source", "CIPS Legacy Document", _
"Meta-Roles(DocLvl)", "SME Reviewer", "SourceDocs", "Meta-ReqType", "Meta-Roles", "Meta-Input", "Meta-Output", "Meta-Toolset", _
"Meta-Sources", "Meta-Traced", "Meta-Objective_Evidence")
For Each element In arrWsNames
FindStyleReplaceWithCC ActiveDocument, CStr(element)
Next element
End Sub
Sub RemoveContentControls(docTarget As Document)
Dim ccIndex As Long
For ccIndex = docTarget.ContentControls.Count To 1 Step -1
With docTarget.ContentControls(ccIndex)
If .LockContentControl = True Then .LockContentControl = False
.Delete False
End With
Next ccIndex
End Sub
Sub FindStyleReplaceWithCC(searchDoc As Document, styleName As String)
Dim findRange As Range
Dim ccRange As Range
Set findRange = searchDoc.Range
With findRange.Find
.ClearFormatting
.Style = ActiveDocument.Styles(styleName)
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
Do While .Execute = True
If findRange.Information(wdWithInTable) Then
findRange.Expand wdCell
End If
Set ccRange = findRange.Duplicate
AddContentControlToRange ccRange, styleName
'need to collapse the findRange so that Find can continue without finding the same location again
findRange.Collapse wdCollapseEnd
Loop
End With
End Sub
Sub AddContentControlToRange(ByVal ccLocation As Range, ByVal ccTitle As String)
ccLocation.ContentControls.Add(wdContentControlRichText).Title = ccTitle
End Sub
EDIT:
To add both a tag and a title to the content control:
Sub AddContentControlToRange(ByVal ccLocation As Range, ByVal ccTitle As String, ByVal ccTag as String)
With ccLocation.ContentControls.Add(wdContentControlRichText)
.Title = ccTitle
.Tag = ccTag
End With
End Sub
I'm using a VBA script to try to find the starting number of a paragraph (they are list items not formatted as such - not trying to format, just find the numbers).
1. First Item
2. Second Item
No number - don't include despite 61.5 in paragraph.
25 elephants should not be included
12. Item Twelve, but don't duplicate because of Susie's 35 items
Is there any way to say in VBA "If start of paragraph has 1-2 numbers, return those numbers". In regex, what I'm looking for is ^(\d\+)\.
Here is a working bit of VBA code - haven't figured out how to CREATE the excel file yet, so if you go to test create a blank test.xslx in your temp folder. Of course this may be simple enough that testing isn't necessary.
Sub FindWordCopySentence()
On Error Resume Next
Dim appExcel As Object
Dim objSheet As Object
Dim aRange As Range
Dim intRowCount As Integer
intRowCount = 1
' Open Excel File
If objSheet Is Nothing Then
Set appExcel = CreateObject("Excel.Application")
'Change the file path to match the location of your test.xls
Set objSheet = appExcel.workbooks.Open("C:\temp\test.xlsx").Sheets("Sheet1")
intRowCount = 1
End If
' Word Document Find
Set aRange = ActiveDocument.Range
With aRange.Find
Do
.ClearFormatting
' Find 1-2 digit number
.Text = "[0-9]{1,2}"
.MatchWildcards = True
.Execute
If .Found Then
' Copy to Excel file
aRange.Expand Unit:=wdSentence
aRange.Copy
aRange.Collapse wdCollapseEnd
objSheet.Cells(intRowCount, 1).Select
objSheet.Paste
intRowCount = intRowCount + 1
End If
Loop While .Found
End With
Set aRange = Nothing
If Not objSheet Is Nothing Then
appExcel.workbooks(1).Close True
appExcel.Quit
Set objSheet = Nothing
Set appExcel = Nothing
End If
End Sub
Thanks!
I would go quite a bit simpler and just check the first few characters of the paragraph:
Option Explicit
Sub test()
Dim para As Paragraph
For Each para In ThisDocument.Paragraphs
With para.Range
If (.Characters(2) = ".") Or (.Characters(3) = ".") Then
If IsNumeric(para.Range.Words(1)) Then
Debug.Print "Do something with paragraph number " & _
para.Range.Words(1) & "."
End If
End If
End With
Next para
End Sub
A more efficient approach, which obviates the need to test every paragraph:
Sub Demo()
Application.ScreenUpdating = False
Dim StrOut As String
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "^13[0-9.]{1,}" ' or: .Text = "^13[0-9]{1,}
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
StrOut = StrOut & .Text
' or: MsgBox Split(.Text, vbCr)(1)
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Application.ScreenUpdating = True
MsgBox StrOut
End Sub
As coded, the macro returns the entire list strings where there may be multiple levels (e.g. 1.2). Comments show how to find just the first number where there may be multiple levels and how to extract that number for testing (the Find expression includes the preceding paragraph break).
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
I have a macro in Word that searches a document, and then does things when found.
I would like to check if the Found text is in a table of contents, but it doesn't seem to be liking how I have the code:
Sub test()
Dim myDoc As Word.Document
Dim oRng As Word.Range, rng As Word.Range, rngXE As Word.Range
Dim addDefinition$, editedDefinition$ ',findText$
Dim rngEdited
Dim bFound As Boolean
Dim findText() As Variant
Dim y&
Set myDoc = ActiveDocument
bFound = True
Call Clear_Index
findText = Array("whatever", "whatever:", "Whatever:")
For y = LBound(findText) To UBound(findText)
'Loop through the document
Set oRng = myDoc.Content
Set rngXE = oRng.Duplicate
With oRng.Find
.ClearFormatting
.ClearAllFuzzyOptions
.Text = findText(y)
.MatchCase = False
.Wrap = wdFindStop
End With 'orng.find
Do While bFound
bFound = oRng.Find.Execute
If bFound Then
Set rngXE = oRng.Paragraphs(1).Range.Duplicate
rngXE.Select
'
' THIS IS WHERE I NEED HELP :(
If rngXE.Fields.Type = wdFieldTOC Then ' This doesn't work.
MsgBox (" In a TOC!")
End If
End If
End Sub
It throws
Compile Error: Method or data member not found
I've seen loops of
For each fld in myDoc.Fields
If fld.Type = wbFieldTOC Then
'Do something
end if
next fld
Which work - I'm just having a hard time understanding to find specific text's field.
The InRange method is useful for discovering if one range is located within another range. Since there is a TableOfContents collection for the Document object, it's simple enough to get that range and test whether some other ange (even Selection.Range) is within it.
The following snippet assumes the document has a TOC and that you're interested in the first TOC. If your situation is otherwise, you need to do some checking to make sure the reference is to the correct TOC:
oRng.InRange(ActiveDocument.TablesOfContents(1).Range)