I have MS Word document that structure is defined:
I use 3-level numbered item Heading:
5 Heading1
5.1 Heading2
5.1.1 Heading3
.
.
.
5.1.7 Heading3
in Item 5.X.7 I have table with results of my experiment
"X" can start from 1 up to approx 20
I need to search in all items "5.X.7" for tables with results.
Any idea how to select first row, first column in first table in item "5.X.7"?
Since you are new, and even though StackOverflow is not a free coding service ... try something like this to get you started.
Sub FindTables()
Dim doc As Word.Document, rng As Word.Range, hRng As Word.Range
Dim splitStr() As String, tbl As Word.Table
Set doc = ActiveDocument
Set rng = doc.Content
With rng.Find
.ClearFormatting
.Format = True
.Forward = True
.Style = doc.Styles("Heading 3").NameLocal
.Text = ""
.Wrap = wdFindStop
.Execute
Do While .found = True
splitStr = Split(rng.ListParagraphs(1).Range.ListFormat.ListString, ".")
If splitStr(0) = 5 And splitStr(2) = 7 Then
Set hRng = rng.Bookmarks("\HeadingLevel").Range
If hRng.Tables.Count > 0 Then
Set tbl = hRng.Tables(1).Range
'do something with the table
End If
rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
Else
rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
End If
.Execute
Loop
End With
End Sub
Related
I would like to fix the following code to make it find each table in the document where it has the pattern ARC or MEC words followed by the wildcard digits [1-4][1-9]{2} without any leading/trailing characters, digits, spaces, etc.
The chosen table should have a total of 11 rows.
If possible, I need another version of the code to search for the pattern in the table first cell .Cell(1,1) while making sure the table has a total of 11 rows.
Sub FindTables()
Dim wdDoc As Word.Document, t As Long
Set wdDoc = ThisDocument
With wdDoc
For t = 1 To .Tables.Count
With .Tables(t).Range.Find
.ClearFormatting
.Format = FALSE
.Text = "(ARC)|(MEC)[1-4][1-9]{2}"
.Forward = TRUE
.Wrap = wdFindStop
.MatchCase = TRUE
.MatchWildcards = TRUE
.Execute
If .Found = TRUE Then
' some operations on the table
wdDoc.Tables(t).AutoFitBehavior (wdAutoFitWindow)
wdDoc.Tables(t).Range.Collapse wdCollapseEnd
End If
End With
Next
End With
End Sub
For example:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = False
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
.Text = "<[ACEMR]{3}[1-4][1-9]{2}>"
.Replacement.Text = ""
End With
Do While .Find.Execute = True
If .Information(wdWithInTable) = True Then
If .Tables(1).Rows.Count = 11 Then
'If .Cells(1).RowIndex = 1 And .Cells(1).ColumnIndex = 1 Then
If Split(.Cells(1).Range.Text, vbCr)(0) = .Text Then
Select Case Left(.Text, 3)
Case "ARC", "MEC": .Tables(1).AutoFitBehavior (wdAutoFitWindow)
End Select
End If
'End If
End If
.Start = .Tables(1).Range.End
End If
.Collapse wdCollapseEnd
Loop
End With
Application.ScreenUpdating = True
End Sub
To process only those tables where the found content is in the first cell, delete the tick marks from the two comment-out lines.
Pattern:
"(ARC[1-4][1-9]{2})|(MEC[1-4][1-9]{2})"
Tested successfully with Microsoft VbScript Regular Expressions 5.5. (set this Reference on VBE).
Code sample - adapt it to suit your needs (working with tables - I didn't reproduce your scenario):
Function fnFindPatterns()
Dim objRegExp As RegExp
Dim ObjMatch As Match
Dim colMatches As MatchCollection
Dim strText As String
Dim strResult As String
Set objRegExp = New RegExp
objRegExp.Pattern = "(ARC[1-4][1-9]{2})|(MEC[1-4][1-9]{2})"
objRegExp.IgnoreCase = True
objRegExp.Global = True
Selection.WholeStory
strText = Selection.Text
If objRegExp.Test(strText) = True Then 'we have something there...
Set colMatches = objRegExp.Execute(strText)
For Each ObjMatch In colMatches 'Iterate on the collection
strResult = strResult & ObjMatch.Value & vbCrLf
Next
Else
End If
MsgBox strResult
End Function
Edited 2022 07 11:
I realized that the "|" (OR) do not work in MSWord . It doesn't exist on the limited "Regular Expressions" set of tools within MsWord, compared to VbScript.RegExp. Wich, in turn, is also limited set of tools, if compared with other (powerfull) programming languages. But with some coding we "simulate" this OR, using "Choose", testing each partial set of patterns that way:
Sub FindTables()
Dim wdDoc As Word.Document, t As Long, intChoose As Integer
Set wdDoc = ThisDocument
With wdDoc
For intChoose = 1 To 2
For t = 1 To .Tables.Count
With .Tables(t).Range.Find
.ClearFormatting
.Format = False
.Text = VBA.Choose(intChoose, "<[ARC]{3}[1-4][1-9]{2}>", "<(MEC)[1-4][1-9]{2}>")
.Forward = True
.Wrap = wdFindStop
.MatchCase = True
.MatchWildcards = True
.Execute
If .Found = True Then
' some operations on the table
wdDoc.Tables(t).AutoFitBehavior (wdAutoFitWindow)
wdDoc.Tables(t).Range.Collapse wdCollapseEnd
End If
End With
Next
Next
End With
End Sub
To test this code I mounted a Word Doc with 7 tables (varying dimensions from 1 x 11 to 1 x 13). To ensure the correct dimension of each table insert the suggestion posted in Macropod's code.
I'd like to find the location of a heading that has a specific heading number. E.g. "2.3."
For some reason, I can only find the location of the heading if i specify what Style that heading is going to be. If i don't specify the heading style then I don't get any matches (i.e. .Execute is never True).
How can I find the location of a heading without having to specify it's style?
Code that works:
Function FindHeadingPos(oRng As Word.Range) As Long
Dim rng As Word.Range
With oRng.Find
.ClearAllFuzzyOptions
.ClearHitHighlight
.ClearFormatting
.Text = ""
.Forward = True
.Wrap = 2
.Format = True
.Style = "Heading 2,H2 Numb"
Do While .Execute
'.Parent contains the found range
Set rng = .Parent
If rng.ListFormat.ListString = "2.3." Then
FindHeadingPos = rng.Start
Exit Do
End If
'below statement seems to prevent code hanging on some headings.
rng.Collapse Direction:=wdCollapseEnd
Loop
End With
End Function
Code that doesn't work:
Function FindHeadingPos(oRng As Word.Range) As Long
Dim rng As Word.Range
With oRng.Find
.ClearAllFuzzyOptions
.ClearHitHighlight
.ClearFormatting
.Text = ""
.Forward = True
.Wrap = 2
'.Format = True
'.Style = "Heading 2,H2 Numb"
Do While .Execute
'.Parent contains the found range
Set rng = .Parent
If rng.ListFormat.ListString = "2.3." Then
FindHeadingPos = rng.Start
Exit Do
End If
'below statement seems to prevent code hanging on some headings.
rng.Collapse Direction:=wdCollapseEnd
Loop
End With
End Function
Thanks #GSerg for suggesting the .ParagraphFormat.OutlineLevel property.
The code below seems to solve my problem in case it helps anyone else.
Function getParaOutlineLevel(headNumberRaw As String) As Integer
Dim numberOfDecimals As Integer
numberOfDecimals = Len(headNumberRaw) - Len(Replace(headNumberRaw, ".", ""))
If Not IsNumeric(Left(headNumberRaw, 1)) Then
getParaOutlineLevel = numberOfDecimals + 5
Else
getParaOutlineLevel = numberOfDecimals
End If
End Function
Function FindHeadingPos(oRng As Word.Range) As Long
Dim headNumber As String
Dim rng As Word.Range
headNumber = "2.3."
With oRng.Find
.ClearAllFuzzyOptions
.ClearHitHighlight
.ClearFormatting
.Text = ""
.Forward = True
.Wrap = 2
.Format = True
.ParagraphFormat.OutlineLevel = getParaOutlineLevel(headNumber)
Do While .Execute
'.Parent contains the found range
Set rng = .Parent
If rng.ListFormat.ListString = headNumber Then
FindHeadingPos = rng.Start
Exit Do
End If
'below statement seems to prevent it hanging on some headings.
rng.Collapse Direction:=wdCollapseEnd
Loop
End With
End Function
I have the following code to find headings (ranging from heading 1-4) with the word "DELETE" in the heading to delete the heading and the text underneath, as well as nested headings. However, it stops after deleting the first set of headings it finds. How can I get it to work through all the headings in the document? Thank you!
Sub deleteheading()
Dim rngHeading1 As Range
Set rngHeading1 = GetHeadingBlock("DELETE", wdStyleHeading1)
If Not rngHeading1 Is Nothing Then rngHeading1.Delete
Dim rngHeading2 As Range
Set rngHeading2 = GetHeadingBlock("DELETE", wdStyleHeading2)
If Not rngHeading2 Is Nothing Then rngHeading2.Delete
Dim rngHeading3 As Range
Set rngHeading3 = GetHeadingBlock("DELETE", wdStyleHeading3)
If Not rngHeading3 Is Nothing Then rngHeading3.Delete
Dim rngHeading4 As Range
Set rngHeading4 = GetHeadingBlock("DELETE", wdStyleHeading4)
If Not rngHeading4 Is Nothing Then rngHeading4.Delete
End Sub
Function GetHeadingBlock(headingText As String, headingStyle As WdBuiltinStyle) As Range
Dim rngFind As Range
Set rngFind = ActiveDocument.Content
With rngFind.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "DELETE"
.style = headingStyle
.Replacement.Text = ""
.Forward = True
.Format = True
.Wrap = wdFindStop
If .Execute Then Set GetHeadingBlock = _
rngFind.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
End With
End Function
For example:
Sub DeleteHeadingSpanText()
Application.ScreenUpdating = False
Dim h As Long
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "DELETE"
.Replacement.Text = ""
.Format = True
.Forward = True
.MatchCase = True
.MatchWholeWord = True
.Wrap = wdFindContinue
End With
For h = 1 To 9
.Style = "Heading " & h
Do While .Find.Execute
.Duplicate.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel").Text = vbNullString
Loop
Next
End With
Set RngHd = Nothing
Application.ScreenUpdating = True
End Sub
Change the 1 & 9 in 'For h = 1 To 9' to define whatever heading levels you want to limit the code's scope to.
This code calls your own function GetHeadingBlock.
Sub DeleteHeading()
Dim rngHeading As Range
Dim i As WdBuiltinStyle
For i = wdStyleHeading1 To wdStyleHeading4 Step -1
Do
Set rngHeading = GetHeadingBlock("DELETE", i)
If rngHeading Is Nothing Then
Exit Do
Else
rngHeading.Delete
End If
Loop
Next i
End Sub
I am working to develop code that is to be used as a part of a greater code set that will ultimately answer how many times a specific word appears on a single specified page within a Word document that could have many pages in it.
What the code is actually attempting to accomplish is to search for a phrase on only one page at a time, find that phrase, then copy the string immediately following where that phrase was found on that page and pasting string to a different word doc. If you anyone can come up with a better approach than what I have below I am open to changing things up, as this has been much more difficult of a task than what I thought it would be in the beginning.
Sub test()
'Find and Define Documents
Dim doc As Document
For Each doc In Documents
If Left(doc.Name, 5) = "LEGAL" Then
Dim MainDoc As Document
Set MainDoc = doc
End If
Next doc
For Each doc In Documents
If doc.Name = "Document1" Then
Dim OtherDoc As Document
Set OtherDoc = doc
End If
Next doc
'Start from top of main doc.
MainDoc.Activate
Selection.GoTo What:=(0)
'count # of pages in main doc.
Dim iCount As Integer
iCount = 0
'Do for other procedures to be accomplished in the code
Do While iCount < ActiveDocument.BuiltInDocumentProperties("Number of Pages")
iCount = iCount + 1
MainDoc.Activate
Dim Range_Doc As Range
Set Range_Doc = MainDoc.GoTo(What:=wdGoToPage, Name:=iCount)
Set Range_Doc = Range_Doc.GoTo(What:=wdGoToBookmark, Name:="\page")
'Find & Count the number of times the word Apple appears on specific page
Dim AppleCount As Integer
If AppleCount > 0 Then
Dim OriginalCount As Integer
OriginalCount = AppleCount
End If
AppleCount = 0
Range_Doc.Bookmarks("\page").Range.Select
'Selection.MoveRight Unit:=wdCharacter, Count:=1
With Selection.Find
.Text = "Apple"
.Format = False
.Wrap = 0
.Forward = False
Do While .Execute
AppleCount = AppleCount + 1
Loop
End With
Dim NewCount As Integer
NewCount = AppleCount - OriginalCount
If NewCount < 0 Then
NewCount = 0
End If
'Locate where in the doc the find term was found and extract what is coming after it
Set Range_Doc = MainDoc.GoTo(What:=wdGoToPage, Name:=iCount)
Set Range_Doc = Range_Doc.GoTo(What:=wdGoToBookmark, Name:="\page")
Dim objFind As Find
Set objFind = Range_Doc.Find
With Range_Doc.Find
Counter = 0
Do While .Execute(findText:="Apple", MatchWholeWord:=False, Forward:=True) = True And Counter < NewCount
With Range_Doc
Set objFind = Range_Doc.Find
If objFind.Found Then
Dim Range_Found As Range
Set Range_Found = objFind.Parent
Dim IntPos as Integer
IntPos = Range_Found.End
Dim AppleID
Set AppleID = MainDoc.Range(Start:=IntPos, End:=IntPos + 33)
OtherDoc.Content.InsertAfter ","
OtherDoc.Content.InsertAfter AppleID
End If
End With
Counter = Counter + 1
Loop
End With
Loop
End sub
Perhaps something based on:
Sub Demo()
Application.ScreenUpdating = False
Dim DocSrc As Document, DocTgt As Document, Rng As Range
Set DocSrc = ActiveDocument: Set DocTgt = Documents.Add
With DocSrc
Set Rng = .Range.GoTo(What:=wdGoToPage, Name:=3)
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\page")
With Rng.Duplicate
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "Apple"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
Do While .Find.Found
If .InRange(Rng) = False Then Exit Do
.Collapse wdCollapseEnd
.End = .Paragraphs(1).Range.End -1
DocTgt.Range.Characters.Last.Text = vbCr & .Text
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
End With
Application.ScreenUpdating = True
End Sub
where the content you're interested in is on page 3.
I am in the process of putting together a Word macro (below) that parses a table of acronyms in one Word document and highlights every occurrence of these acronyms in another Word document. This appears to be functional.
However, I would like to also have the macro differentiate acronyms that are in parentheses from those that are not. For example,
The soldier is considered Away Without Leave (AWOL). AWOL personnel are subject to arrest.
It seems as though the range "oRange" that defines the found acronym could be evaluated, if it is first expanded in the Do-While loop using this code:
oRange.SetRange Start:=oRange.Start - 1, End:=oRange.End + 1
However, none of my attempts to code a solution seem to work (they put the macro into an infinite loop or result in error messages). I'm fairly new to VBA programming and am obviously missing something regarding how the loops are operating.
My question is: is there a way to duplicate the range "oRange" for subsequent manipulation or is there some other method that I should be using?
Thanks for any assistance you can provide!
Sub HighlightAcronyms()
Dim wdDoc As Object
Dim wdFileName As Variant
Dim TableNo As Integer 'table number in Word
Dim oRow As Row
Dim oCell As Cell
Dim sCellText As String
Dim oDoc_Source As Document
Dim strListSep As String
Dim oRange As Range
Dim n As Long
Dim sCellExpanded As String
'Application.ScreenUpdating = False
strListSep = Application.International(wdListSeparator)
'*** Select acronym file and check that it contains one table
wdFileName = WordApplicationGetOpenFileName("*.docx", True, True)
If wdFileName = False Then Exit Sub '(user cancelled import file browser)
Set wdDoc = GetObject(wdFileName) 'open Word file
With wdDoc
TableNo = wdDoc.Tables.Count
If TableNo = 0 Then
MsgBox "The file """ & wdFileName & """ contains no tables.", _
vbExclamation, "Import Word Table"
ElseIf TableNo > 1 Then
MsgBox "The file """ & wdFileName & """ contains multiple tables.", _
vbExclamation, "Import Word Table"
End If
End With
'*** steps through acronym column
wdDoc.Tables(1).Cell(1, 1).Select
Selection.SelectColumn
For Each oCell In Selection.Cells
' Remove table cell markers from the text.
sCellText = Left$(oCell.Range, Len(oCell.Range) - 2)
sCellExpanded = "(" & sCellText & ")"
n = 1
'need to find foolproof method to select document for highlighting
Documents(2).Activate
Set oDoc_Source = ActiveDocument
With oDoc_Source
Set oRange = .Range
With oRange.Find
.Text = sCellText
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWildcards = False
Do While .Execute
If n = 1 Then
oRange.HighlightColorIndex = wdGreen
Else
oRange.HighlightColorIndex = wdYellow
End If
'trying to add code here to expand oRange and compare it to sCellExpanded
n = n + 1
Loop
End With
End With
Next oCell
Set wdDoc = Nothing
End Sub
Try This
Define two ranges instead of merging the oRange.
See this sample code (TRIED AND TESTED)
Sub Sample()
Dim strSearch As String, sCellExpanded As String
Dim oRange As Range, newRange As Range
strSearch = "AWOL"
sCellExpanded = "(" & strSearch & ")"
Set oRange = ActiveDocument.Range
With oRange.Find
.ClearFormatting
.Text = strSearch
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
Do While .Execute
If n = 1 Then
oRange.HighlightColorIndex = wdGreen
Else
oRange.HighlightColorIndex = wdYellow
End If
'~~> To check if the found word is not the 1st word.
If oRange.Start <> 0 Then
Set newRange = ActiveDocument.Range(Start:=oRange.Start - 1, End:=oRange.End + 1)
If newRange.Text = sCellExpanded Then
'
'~~> Your code here
'
newRange.Underline = wdUnderlineDouble
End If
End If
n = n + 1
Loop
End With
End Sub
SNAPSHOT
Unable to upload image at the moment. imgur server is down at the moment.
You may see this link
http://wikisend.com/download/141816/untitled.png