I have a word document in which I would like to select the full text of the heading starting with enumeration 2.3.1 until (not included) the heading 2.3.2 or [End of File]. If there are 'smaller' subsections or pictures or tables in between, they should also be selected.
PS: Example:
...
2.2 Blah
Blah
2.3 Blubb
Blubb
[Start Selection]
2.3.1 Important1
Important2
[Picture: Important3]
[Table: Important4]
2.3.1.1 Important 5
Important 6
[Stop Selection]
2.3.2 Blieh
I have experimented with navigating through every paragraph, but this is quite slow. I need this feature to copy the selection afterwards (I already know how to do that ;-)).
Thank you very much for help!
Jan
This seems to work well.
Adjust the format setting so that it finds '2.3.1' etc. only in that given format type.
Sub Macro1()
Selection.WholeStory
Selection.Collapse wdCollapseStart
Selection.Find.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles("Caption 1")
With Selection.Find
.Text = "2.3.1"
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = True
End With
Selection.Find.Execute
Selection.Collapse wdCollapseStart
Dim r1 As Range
Set r1 = Selection.Range
' keep format settings, only change text
Selection.Find.Text = "2.3.2"
If Selection.Find.Execute Then
Selection.Collapse wdCollapseStart
Else
Selection.WholeStory
Selection.Collapse wdCollapseEnd
End If
Dim r2 As Range
Set r2 = ActiveDocument.Range(r1.Start, Selection.Start)
r2.Select
End Sub
This is the VBA Macro I'm using to select the text between headings. However, it only selects between any two headings of any level. It won't include smaller subheadings.
Sub SelectBetweenHeadings()
With Selection
.GoTo What:=wdGoToHeading, Which:=wdGoToPrevious
.Collapse
Dim curRange As Range
Set curRange = .Range
.Extend
.GoTo What:=wdGoToHeading, Which:=wdGoToNext
If .Range = curRange Then
.EndKey Unit:=wdStory
End If
.ExtendMode = False
End With
End Sub
Related
I have used 90 times heading 2 in my Word document of + 1000 pages. Every heading two has numerous subheadings. The end goal is to add a separate Table Of Content (TOC) under each heading 2 which shows only the subheadings under that specific heading 2 (the text of heading 2 itself excluded, which by itself can be done by limiting the TOC to headings 3 and smaller). Searching the net made it clear that this is not as simple as it sounds. There is for instance not a checkbox in the TOC options to limit the TOC to the next section break, so using section breaks is pointless to achieve this. The only method seems to be to add separate bookmarks to all the text under each heading 2 and to limit the TOC code to the bookmark in question where the TOC is situated.
I can't figure out a way to automatically create uniquely named bookmarks (for instance numbers 1 to 90 in my case) for each of the text selections under each heading 2. So I'm willing to do this manually. But it would already be a help not to select manually all the text under each heading 2.
So here is the question: which VBA code can help me with this selection? Or can you think of a code that goes much further in achieving the end goal?
The farthest I got was to find a heading 2 add two unusual symbols "£$" in front of it, go to the next heading 2 do the same and so on. The idea here is, once that is done, I just need to search with wild cards on $*£ to select the text from the one heading 2 to the next.
But my code keeps on looping (when the end of the document is reached it starts over from the top), and since today it doesn't seem to be working at all anymore. And, admittedly, maybe the whole method is a bit crappy. I nevertheless paste the code on the bottom.
A helping hand would be much appreciated, either by improving my code, by sharing other code that selects text under the next heading 2 in the document (a macro which I then can repeat manually to continue creating manual bookmarks in the document) or by finding a much better method to achieve the end goals of separate TOCs under each heading 2 with only the headings shown under that specific heading.
Thanks a lot in advance.
Willem
Do While Selection.Find.Found = True
Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles("Kop 2")
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
If Selection.Find.Found Then
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.TypeText Text:="$£"
Selection.MoveDown Unit:=wdLine, Count:=4
End If
Loop
For example:
Sub AddHeading2TOCs()
Application.ScreenUpdating = False
Dim RngHd As Range, h As Long
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Style = wdStyleHeading2
.Format = True
.Forward = True
.Wrap = wdFindStop
End With
Do While .Find.Execute
Set RngHd = .Paragraphs(1).Range: h = h + 1
RngHd.InsertAfter vbCr
Set RngHd = RngHd.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
With RngHd
.Paragraphs(2).Range.Style = wdStyleNormal
.Start = .Paragraphs(2).Range.End
.Bookmarks.Add "BkMkHd" & h, .Duplicate
.Start = .Start - 1
.Collapse wdCollapseStart
.Fields.Add .Duplicate, wdFieldEmpty, "TOC \b BkMkHd" & h, False
End With
.Collapse wdCollapseEnd
Loop
End With
Set RngHd = Nothing
Application.ScreenUpdating = True
End Sub
I'm new to VBA for Word (have used it a fair bit in Excel). I am trying to organise large word documents that contain copied and pasted emails. I want to find the date/time of each email and copy and paste it to the top of the page. All lines containing the date start with "Date:" so it is easy enough to find them. I wrote a code to try and copy them to the tops of pages but it currently pastes all of the date lines to the top of the document. I can see why, I just can't work out how to change it.
What I will then be able to do is make the first line of each page into a heading which I can sort by.
My initial code is as follows:
Sub Copy_Dates_to_Top()
If Selection.StoryType <> wdMainTextStory Then
With ActiveDocument.ActiveWindow.View
.Type = wdPrintView
.SeekView = wdSeekMainDocument
End With
End If
Selection.HomeKey Unit:=wdStory
With Selection.Find
.Text = "Date: "
.Format = False
.Forward = True
.MatchWildcards = False
.Wrap = wdFindStop
While .Execute
Selection.Expand Unit:=wdLine
Selection.Copy ' Unit:=wdLine
Selection.GoTo What:=wdGoToBookmark, Name:="\Page"
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.Paste
Wend
End With
End Sub
You can achieve this quite easily by applying a unique Style to the dates, then referencing that Style via a STYLEREF field in the page header. For example, the following macro employs Word's built-in 'Strong' character Style for this.
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument
With .Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "Date: [0-9]{1,2}/[0-9]{1,2}/[0-9]{4}"
.Replacement.Text = "^&"
.Forward = True
.Format = True
.Replacement.Style = "Strong"
.Wrap = wdFindContinue
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
.Fields.Add Range:=.Sections.First.Headers(wdHeaderFooterPrimary).Range, _
Type:=wdFieldEmpty, Text:="STYLEREF Strong", PreserveFormatting:=False
End With
Application.ScreenUpdating = True
End Sub
Word's 'Strong' Style applies bold formatting, which make the dates stand out more in the document body also.
Note: The macro assumes your dates are in either a d/m/y or m/d/y format; the Find expression could be changed to match a different date format.
I'm generating some security report in Microsoft Word - importing SOAP xml requests and responses...
I want to automate this process as much as I can and I need to highlight some text in these requests/responses. How to do that? In general I need to highlight non-standart inputs in requests (every time different - bad data types and so on) and fault strings in responses (in majority looks like this <faultstring>some error</faultstring>).
Heres code Im trying:
Sub BoldBetweenQuotes()
' base for a quotes finding macro
Dim blnSearchAgain As Boolean
' move to start of doc
Selection.HomeKey Unit:=wdStory
' start of loop
Do
' set up find of first of quote pair
With Selection.Find
.ClearFormatting
.Text = "<faultstring>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Execute
End With
If Selection.Find.Found Then
Selection.MoveRight Unit:=wdCharacter, Count:=1
' switch on selection extend mode
Selection.Extend
' find second quote of this pair
Selection.Find.Text = "</faultstring>"
Selection.Find.Execute
If Selection.Find.Found Then
Selection.MoveLeft Unit:=wdCharacter, Count:=Len(Selection.Find.Text)
' make it bold
Selection.Font.Bold = True
Selection.Collapse Direction:=wdCollapseEnd
Selection.MoveRight Unit:=wdCharacter, Count:=1
blnSearchAgain = True
Else
blnSearchAgain = False
End If
Else
blnSearchAgain = False
End If
Loop While blnSearchAgain = True
End Sub
It highlights just the first faultstring, but other appearences stay unformated nad I dont know why.... Thanks for your reply.
The most efficient way to do this is to work with multiple Range objects. Think of a Range as being like an invisible selection, with the important difference that, while there can be but one Selection object there can be multiple Range objects in your code.
I've adapted your code, adding three Range objects: one for the entire document; one for finding the starting tag; one for finding the end tag. The Duplicate property is used to "copy" one Range from another (this due to an oddity in Word if you Set one Range to another, which links them).
For clarity I also added a couple more Boolean test values for your Ifcomparisons. In my experience, it's more reliable to pick up the "success" directly from Execute than to rely on Find.Found after-the-fact.
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
With the Find function(Ctrl+F) I can search and select all words in Italicized font from a document.
How would this be done with vba?
I tried the macro recorder but the code I get there does not work.
Sub Makro1()
'
' Makro1 Makro
' Makro aufgezeichnet am 16.06.2011 von u0327336
'
Selection.Find.ClearFormatting
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
End Sub
The goal would be to have all italic font words being selected/highlighted in the document.
thanks,
kay
The last effort actually works a treat in Word 2010. I'm not sure why the report was that it didn't work.
Here it is changed to ASCIIfy italics, which is what I want for text-based newsgroups:
Sub ASCIIfy()
Dim myString As Word.Range
Set myString = ActiveDocument.Content
With myString.Find
'// ensure unwanted formats aren't included as criteria
.ClearFormatting
'// we don't care what the text is
.Text = ""
'// find the italic text
.Font.Italic = True
'// loop for each match and surround with "_"
While .Execute
myString.Text = "_" & myString & "_"
myString.Font.Italic = False
myString.Collapse wdCollapseEnd
Wend
End With
End Sub
You may need to add :
Selection.Find.Font.Italic = True
That could became :
With Selection.Find
.Text = ""
.FOnt.Italic = True
'other search stuff
End with
EDIT: another try (not complete though)
Sub hilightItalic()
With ActiveDocument.Content.Find
' to ensure that unwanted formats aren't included as criteria
.ClearFormatting
'You don't care what the text is
.Text = ""
'Find the italic text
.Font.Italic = True
'Delete the text found
.Replacement.Text = ""
'delete all italic text
.Execute Replace:=wdReplaceAll
'.HitHighlight "", vbYellow, vbRed
End With
End Sub
But yet, the replace does work well but highlight does not work if there is no text. Anyone has an idea ?
EDIT 2: Found a working solution, even if i did not manage to have hithighlight working though
Sub hilightItalic()
Dim oRng As Word.Range
Set oRng = ActiveDocument.Content
With oRng.Find
' to ensure that unwanted formats aren't included as criteria
.ClearFormatting
'You don't care what the text is
.Text = ""
'Find the italic text
.Font.Italic = True
'Loop for each match and set a color
While .Execute
oRng.HighlightColorIndex = wdDarkYellow
oRng.Collapse wdCollapseEnd
Wend
End With
End Sub
Regards,
Max
Set Selection.Find.Font.Italic = True.
Selection.Find.ClearFormatting
' The next line does the trick.
Selection.Find.Font.Italic = True
With Selection.Find
.Text = "YourText"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Hint for the next time: Record a macro, perform the actions you want to automate, and look what code is recorded. That's how I found this. :D
[edit]
I see that you tried recording it. Weird that that didn't work.. :-S
You need to iterate through the cells in the range that you want to check, and specifically check if it has its font italicized. AFAIK .Italic is not a "findable" option.
The following code is an example of iterating through the cells to find what you need.
Sub TestMe2()
Dim rng As Range
'// change as needed to the proper worksheet reference
With ThisWorkbook.Worksheets(1)
'// replace the .Range statement with an appropriate range for your data
For Each rng In .Range(.Cells(1, 1), .Cells(100, 100))
If rng.Font.Italic = True Then
'// uses the yellow highlight color, change to suit your needs
rng.Interior.Color = 65535
End If
Next rng
End With
End Sub
I'm trying to extract bold text using the range.find method and all is peachy except if the entire range is actually bold (not likely to happen much, it's more of an edge condition).
With rngFindRange.Find
.ClearFormatting
.Font.Bold = True
Do
.Execute
If Not .Found Then
Exit Do
End If
'do something with found text'
Set rngFindRange = ActiveDocument.Range(rngFindRange.End + 1, Selection.End)
Loop
The above matches bold text right at the start or right at the end, even both but not when the entire range is bold. I think I might have to test the range.font.bold = true before searching through the range. What does stackoverflow think?
This should find any bold text:
Sub SearchBoldText()
Dim rng As Range
Set rng = ThisDocument.Range(0, 0)
With rng.Find
.ClearFormatting
.Format = True
.Font.Bold = True
While .Execute
rng.Select
rng.Collapse direction:=wdCollapseEnd
Wend
End With
Set rng = Nothing
End Sub