Knowing many programming languages, I don't have experience with changing very large Word files. Please help. The would be of tremendous help!
Can I do this by macro, VBA or Apache.POI? My first try is VBA (psuedo code), see below.
Requirement 1: How can I delete the first paragraph directly after a 'heading 2' style?
Requirement 2: The paragraph to be deleted should start with a number.
Requirement 3: The paragraph should contain italics text. And have style 'normal' or standard.
Should this be something like (pseudo code):
Sub DeleteParagraphAfterHeading2StaringWithNumberBeingItalics()
heading2Found = False
Dim para As Paragraph
For Each para In ActiveDocument.Paragraphs
If para.Style = wdStyleHeading2
heading2Found = True
ElseIf heading2Found = True Then
txt = para.Range.Text
If ( para.Style = wdStyleNormaltext ) And _
( txt.startsWith( number) ) And _
( para.Range.Font.Italic = True) Then
para.Range.Delete
End If
heading2Found = False
Else
heading2Found = False
End if
Next para
End Sub
Doing this by hand would take many days. So, if you can help,
For example:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Style = wdStyleHeading2
.Forward = True
.Wrap = wdFindStop
.Format = True
End With
Do While .Find.Execute
With .Paragraphs.Last.Next.Range.Paragraphs.First.Range
If .Style = wdStyleNormal Then
If .Font.Italic = True Then
If IsNumeric(Trim(.Words.First)) Then .Delete
End If
End If
End With
.Collapse wdCollapseEnd
Loop
End With
Application.ScreenUpdating = True
End Sub
I think the code could be like this (requires debugging on real text with real localized styles):
Sub del_para()
With ActiveDocument.Range
.Find.ClearFormatting
.Find.Style = ActiveDocument.Styles("Heading 2") ' adjust style name
Do
If .Find.Execute Then 'find by style
.Move Unit:=wdParagraph
.Expand Unit:=wdParagraph
If (.ListFormat.ListType = wdListOutlineNumbering _
Or .ListFormat.ListType = wdListSimpleNumbering _
Or Left(.Text, 1) Like "[0-9]") _
And .Style = ActiveDocument.Styles("normal") _
And .Font.Italic Then
.Font.ColorIndex = wdRed ' for debug
'.Delete
End If
Else
Exit Do
End If
.Collapse wdCollapseEnd
Loop
End With
End Sub
Related
Goodevening everybody,
I made a VBA code which loops through all the words in a document and checks if the used font of that word is SimSun. If the font is SimSun, the word should be marked for the overall index. So I made this code:
Sub toevoegen()
Dim doc As Document
Set doc = ActiveDocument
For Each sentence In doc.StoryRanges
For Each w In sentence.Words
If w.Font.Name = "SimSun" Then
doc.Indexes.MarkEntry Range:=Selection.Range, Entry:=w
End If
Next
Next
End Sub
The code works, but there is one problem. The index entries are placed at the end of the document. I want them to be placed after the words which where marked. So this is the result when you run the code:
And I want it to be after the word SimSun and Previous. I am stuck. Can somebody help me?
Using Find/Replace is likely to be far quicker than looping through every 'sentence':
Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, StrIdx As String
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Forward = True
.Format = False
.Wrap = wdFindStop
.Font.Name = "SimSun"
End With
Do While .Find.Execute
StrIdx = .Text
.Collapse wdCollapseEnd
.Fields.Add .Duplicate, wdFieldEmpty, "XE " & StrIdx, False
.MoveEndUntil Chr(21), wdForward
.End = .End + 1
.Font.Reset
If .Information(wdWithInTable) = True Then
If .End = .Cells(1).Range.End - 1 Then
.End = .Cells(1).Range.End
.Collapse wdCollapseEnd
If .Information(wdAtEndOfRowMarker) = True Then
.End = .End + 1
End If
End If
End If
If .End = ActiveDocument.Range.End Then Exit Do
.Collapse wdCollapseEnd
Loop
End With
Application.ScreenUpdating = True
End Sub
It is putting the index entry at your selection point.
You can move the selection point.
Try:
Sub toevoegen()
Dim doc As Document
Set doc = ActiveDocument
For Each sentence In doc.StoryRanges
For Each w In sentence.Words
If w.Font.Name = "SimSun" Then
w.Select
Selection.Collapse (wdCollapseEnd)
doc.Indexes.MarkEntry Range:=Selection.Range, Entry:=w
End If
Next
Next
End Sub
That will insert the index entry just after the target word. Running it multiple times will result in multiple entries for each word.
Sorry, I'm not comfortable with VBA code but, in my Word document (.docx) there are multiple highlight colors and, for example, I need to select all yellow highlights and hide them at one time.
I found this code, but it deletes all yellow highlights after have found them, while I only need them to be selected and hidden:
Sub Highlight()
Dim r As Range
Set r = ActiveDocument.Range
With r.Find
.Highlight = True
Do While .Execute(FindText:="", Forward:=True) = True
If r.HighlightColorIndex = wdYellow Then
r.HighlightColorIndex = wdAuto
r.Collapse 0
End If
Loop
End With
End Sub
Does someone have any idea to help me with this?
The code you found lacks some important checks. Try the following:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Format = False
.Forward = True
.Wrap = wdFindStop
.Highlight = True
End With
Do While .Find.Execute
If .HighlightColorIndex = wdYellow Then .Font.Hidden = True
'The next If ... End If block is needed in case the highlighted content is in a table and includes the end-of-cell marker or end-of-row marker
If .Information(wdWithInTable) = True Then
If .End = .Cells(1).Range.End - 1 Then
.End = .Cells(1).Range.End
.Collapse wdCollapseEnd
If .Information(wdAtEndOfRowMarker) = True Then
.End = .End + 1
End If
End If
End If
'The next line is needed in case the highlighted content includes the final paragraph break
If .End = ActiveDocument.Range.End Then Exit Do
.Collapse wdCollapseEnd
Loop
End With
Application.ScreenUpdating = True
End Sub
From a comparison docx file I need to extract into two word files the text formatted as strikethrough in one docx file and the text formatted as double underline in another docx file to be able to perform the wordcount of newly inserted and deleted text separately.
To do this, I wrote this macro, that actually activates the correct files, but only copies and pastes the formatting resulting from the first search.
Sub WSC_extraction_for_wordcount()
'This macro extracts double underlined text to the file "target_ins"
'This macro extracts strikethrough text to the file "target_del"
Application.ScreenUpdating = False
Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
'STRIKETHROUGH processing
Do
With Selection.Find.Font
.StrikeThrough = True 'Then
Selection.Find.Execute FindText:="", Forward:=True, Format:=True
Selection.Cut
Windows("target_del.docx").Activate
Selection.PasteAndFormat (wdPasteDefault)
Selection.TypeParagraph
Windows("source.docx").Activate
End With
'DOUBLE UNDERLINE processing
With Selection.Find.Font
.Underline = wdUnderlineDouble = True 'Then
Selection.Find.Execute FindText:="", Forward:=True, Wrap:=wdFindContinue, Format:=True
Selection.Cut
Windows("target_ins.docx").Activate
Selection.PasteAndFormat (wdPasteDefault)
Selection.TypeParagraph
Windows("source.docx").Activate
End With
Loop
End Sub
I would be grateful if someone could help me in transforming the options into something like: if the next sentence you encounter is formatted as strikethrough, copy it to file target_del, if the next sentence you encounter is formatted as double underlined, copy it to the file target_ins.
Thank you in advance!
The code below avoids the use of the Selection object. It also assumes that the documents the text is to be moved to are already open.
Sub WSC_extraction_for_wordcount()
'This macro extracts double underlined text to the file "target_ins"
'This macro extracts strikethrough text to the file "target_del"
Application.ScreenUpdating = False
Dim source As Document: Set source = ActiveDocument
Dim targetDel As Document: Set targetDel = Documents("target_del.docx")
Dim targetIns As Document: Set targetIns = Documents("target_ins.docx")
'STRIKETHROUGH processing
With source.Content
With .Find
.ClearFormatting
.Text = ""
.Replacement.ClearFormatting
.Text = ""
.Forward = True
.Format = True
.Wrap = wdFindStop
.Font.StrikeThrough = True
End With
Do While .Find.Execute
targetDel.Characters.Last.FormattedText = .FormattedText
targetDel.Characters.Last.InsertParagraphAfter
.Delete
Loop
End With
'DOUBLE UNDERLINE processing
With source.Content
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = True
.Font.Underline = wdUnderlineDouble
End With
Do While .Find.Execute
targetIns.Characters.Last.FormattedText = .FormattedText
targetIns.Characters.Last.InsertParagraphAfter
.Delete
Loop
End With
End Sub
Without the overhead of creating new documents:
Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, j As Long
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Font.Underline = wdUnderlineDouble
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
End With
Do While .Find.Execute
i = i + .ComputeStatistics(wdStatisticWords)
If .Information(wdWithInTable) = True Then
If .End = .Cells(1).Range.End - 1 Then
.End = .Cells(1).Range.End
.Collapse wdCollapseEnd
If .Information(wdAtEndOfRowMarker) = True Then
.End = .End + 1
End If
End If
End If
If .End = ActiveDocument.Range.End Then Exit Do
.Collapse wdCollapseEnd
Loop
End With
With ActiveDocument.Range
With .Find
.ClearFormatting
.Font.StrikeThrough = True
.Forward = True
.Wrap = wdFindStop
End With
Do While .Find.Execute
j = j + .ComputeStatistics(wdStatisticWords)
If .Information(wdWithInTable) = True Then
If .End = .Cells(1).Range.End - 1 Then
.End = .Cells(1).Range.End
.Collapse wdCollapseEnd
If .Information(wdAtEndOfRowMarker) = True Then
.End = .End + 1
End If
End If
End If
If .End = ActiveDocument.Range.End Then Exit Do
.Collapse wdCollapseEnd
Loop
End With
Application.ScreenUpdating = True
MsgBox i & " words added." & vbCr & j & " words deleted."
End Sub
I'm trying to remove all captions within a specific range (Page 4 until the end of the document).
I would like to remove only the hyperlink and not the text itself.
For example:
Some text here -> Some text here
after removing the hyperlink caption.
I tried:
Sub removeCaptions()
Dim rgePages As Range
Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=4
Set rgePages = Selection.Range
lastPage = ActiveDocument.ActiveWindow.Panes(1).Pages.Count
Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=lastPage
rgePages.End = Selection.Bookmarks("\Page").Range.End
With rgePages.Select
If Range.Style = "Caption" Then
Range.Delete
End If
End With
End Sub
I only get the range without removing the captions.
For example:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Format = True
.Forward = True
.Style = wdStyleCaption
.Wrap = wdFindStop
End With
Do While .Find.Execute
If .Information(wdActiveEndAdjustedPageNumber) > 3 Then .Fields.Unlink
.Collapse wdCollapseEnd
Loop
End With
Application.ScreenUpdating = True
End Sub
I would like to apply a character style ("Bold Italics") to the first two words of all paragraphs set in the "3 Species" style in MS Word (and later, I'd also like another macro to do same for all the words after the second tab in a different style). I know how to do all this in InDesign, but I'd like it set up in the original Word documents before they get flowed into InDesign.
I'm new at this and can't figure out how to apply it to only the first two words. I did get it to apply the character style to the whole paragraph or to a specific word in that style. It seems like it ought to be simple, but I've only learned to use find and replace type functions so far, and I imagine I will have to use the Range functions, which I don't understand yet. Thanks for any help!
Sub Add_Character_Style()
'
' Add_Character_Style Macro
'
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Style = "3 Species"
.Text = ""
.Replacement.Text = ""
.Replacement.Style = "Bold Italics"
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
For example:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "<*>[,. ^s^t]#<*>"
.Style = "3 Species"
.Replacement.Text = ""
.Format = True
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
End With
Do While .Find.Execute
.Style = "Bold Italics"
.Start = .Paragraphs(1).Range.End
Loop
End With
Application.ScreenUpdating = True
End Sub
Try this:
Sub Add_Character_Style()
Dim p As Paragraph
Dim doc As Document: Set doc = ActiveDocument
For Each p In doc.Paragraphs
p.Range.Select
Selection.Collapse Direction:=wdCollapseStart
Selection.MoveRight Unit:=wdWord, Count:=2, Extend:=wdExtend
With Selection
If .Style = "3 Species" Then .Style = "Bold Italic"
End With
Next p
End Sub
EDIT:
To avoid use of the Selection object (Timothy Rylatt)
Sub Add_Character_Style()
Dim p As Paragraph
Dim doc As Document: Set doc = ActiveDocument
Dim rng As Range
For Each p In doc.Paragraphs
If p.Range.Style = "3 Species" Then
Set rng = p.Range
With rng
.Collapse Direction:=wdCollapseStart
.MoveEnd Unit:=wdWord, Count:=2
.Style = "Bold Italics"
End With
End If
Next p
End Sub
FURTHER EDIT per macropod:
Sub Add_Character_Style()
Application.ScreenUpdating = False
Dim Para As Paragraph, Rng As Range
For Each Para In ActiveDocument.Paragraphs
With Para
If .Style = "3 Species" Then
If .Range.ComputeStatistics(wdStatisticWords) > 1 Then
Set Rng = .Range.Words.First
With Rng
Do While .ComputeStatistics(wdStatisticWords) < 2
.MoveEnd wdWord, 1
Loop
.Style = "Bold Italic"
End With
End If
End If
End With
Next
Application.ScreenUpdating = True
End Sub