I need to delete all paragraph marks of ActiveDocument except:
The one which is having Bold-Font after. (Example is in picture, attached)
Bullet-Point paragraph marks.
By using Ranges I came up with the following Code. It works well, but it is not detecting the bullet points. What should I do? I am beginner to use Ranges.
Sub PARAGRAPHSmark()
Dim PARA As Range
Dim p As Range
Set PARA = ActiveDocument.Range
PARA.MoveEnd wdCharacter, -1
Do
Set p = PARA.Duplicate
p.Find.Execute "^13"
PARA.Start = p.End
If p.Find.Found Then
p.MoveEnd wdCharacter, 1
If p.Bold = False Then
p.MoveEnd wdCharacter, -1
' This `If` condition is not detecting bullet when actually its there.
If p.ListFormat.ListType = wdListListNumOnly Or p.ListFormat.ListType = wdListSimpleNumbering Or p.ListFormat.ListType = wdListBullet Then
Else
p.Delete
p.InsertAfter " "
End If
Else
End If
Else
Exit Do
End If
Loop
End Sub
Illustration:
Related
I have been using the following macro to pull out items in parenthesis to comments in word:
'
' CommentBubble Macro
'
'
Dim myRange As Range
Set myRange = ActiveDocument.Content
searchtext = "\(*\)"
With myRange.Find
.MatchWildcards = True
Do While .Execute(findText:=searchtext, Forward:=True) = True
If Len(myRange.Text) > 4 Then
ActiveDocument.Comments.Add myRange, myRange.Text
myRange.Text = ""
End If
Loop
End With
End Sub
The reason I have the length of the text be > 4 is because these are legal documents and I don't want to isolate strings that have things like "in the following conditions: (i) condition 1, (ii) condition 2, etc."
However, here is a snippet of text for which the above code breaks:
This is sample text (with some additional text) that does stuff (with more stuff) and represents 39.4% of shares on the effective date (before giving effect, with some conditions such as ( some stuff (i) and some stuff (ii) with final stuff) and more final stuff) which is subject to (some conditions here) and conclude here.
If you run this you will get the following result:
This is sample text that does stuff and represents 39.4% of shares on the effective date and some stuff (ii) with final stuff) and more final stuff) which is subject to and conclude here.
As you can see the nested parenthesis cause some trouble. Any advice?
Thanks!
You are trying to match parentheses which in Word is a difficult and thankless task as Word only sees opening and closing parentheses as individual characters and not automatically matched by word. The code below finds matching parentheses, eliminates trailing spaces, habdles the case of no parentheses being present, and errors out if you have unbalanced errors. I've left in debugging statements so that you can uncomment them to see what is happening.
Option Explicit
Public Sub ttest()
Dim myRange As Word.Range
Set myRange = ActiveDocument.StoryRanges(wdMainTextStory)
myRange.Collapse direction:=wdCollapseStart
Set myRange = NextParenRange(myRange)
Do Until myRange Is Nothing
DoEvents
Debug.Print myRange.Text
Dim myDupRange As Word.Range
Set myDupRange = myRange.Duplicate
myRange.Collapse direction:=wdCollapseEnd
If myDupRange.Characters.Last.Next.Text = " " Then myDupRange.MoveEnd Count:=1
myDupRange.Delete
Set myRange = NextParenRange(myRange)
Loop
End Sub
Public Function NextParenRange(ByVal ipRange As Word.Range) As Word.Range
Const OpenP As String = "("
Const CloseP As String = ")"
Dim myRange As Word.Range
Set myRange = ipRange.Duplicate
'If myRange.Start <> myRange.End Then myRange.Collapse direction:=wdCollapseStart
'exit if no parentheses exist
'Debug.Print myRange.Start
If myRange.MoveUntil(cset:=OpenP) = 0 Then
Set NextParenRange = Nothing
Exit Function
Else
'Debug.Print myRange.Start
Dim myParenCount As Long
myParenCount = 1
myRange.MoveEnd Count:=1
End If
Do Until myParenCount = 0
' allows VBA to respond to a break key press
DoEvents
' if we run out of parentheses before we get back to zero then flag an error
If myRange.MoveEndUntil(cset:=OpenP & CloseP) = 0 Then
VBA.Err.Raise 17, "Unbalanced parentheses in document"
End If
myRange.MoveEnd Count:=1
'Debug.Print myRange.Characters.Last.Text
'Debug.Print myRange.Characters.Last.Next.Text
myParenCount = myParenCount + IIf(myRange.Characters.Last.Text = OpenP, 1, -1)
Loop
Set NextParenRange = myRange.Duplicate
End Function
My word document template has several local styles that, combined, make a box (boxPara, boxNote, boxTitle, etc). Unfortunately all my boxes are missing the boxTitle paragraphs. My goal is to have a macro that looks for the first boxPara and adds in a blank boxTitle before it - then looks for the boxNote (last item in the box) to reset.
Problem is I'm having difficulty styling the paragraph. The closest I've come is styling the current paragraph wrong, inserting the new paragraph, then re-styling the current paragraph correctly. This seems rather...wrong. And I'd also like to be able to set the text of the inserted paragraph.
Sub addTag()
Dim BoxStart As Integer
Dim Para As Word.Paragraph
BoxStart = 0
For Each Para In ActiveDocument.Paragraphs
If Para.Format.Style = "BoxParagraph" And BoxStart = 0 Then
BoxStart = 1
' Selection.Paragraphs(1).Range.InsertParagraphBefore
Para.Format.Style = "BoxTitle"
Para.Range.InsertParagraph
Para.Format.Style = "BoxParagraph"
' Testing the flag works correctly
' Debug.Print BoxStart
' Debug.Print Para.Range.Text
ElseIf Para.Format.Style = "BoxNote" Then
BoxStart = 0
' Debug.Print BoxStart
End If
Next
End Sub
Here is the solution:
Dim BoxStart As Integer
Dim Para As Word.Paragraph
BoxStart = 0
For Each Para In ActiveDocument.Paragraphs
If Para.Format.Style = "BoxParagraph" And BoxStart = 0 Then
BoxStart = 1
' Insert Box Title with tags before start of answer boxes
' Insert paragraph before current paragraph
Para.Range.InsertParagraphBefore
' Select current paragraph
Para.Range.Select
' Move to previous paragraph
Selection.MoveUp Unit:=wdParagraph, Count:=1
Selection.MoveEnd Unit:=wdCharacter, Count:=-1
' format previous pararaph
Selection.Paragraphs.Format.Style = "BoxTitle"
' Testing the flag works correctly
' Debug.Print BoxStart
' Debug.Print Para.Range.Text
ElseIf Para.Format.Style = "BoxNote" Then
BoxStart = 0
' Debug.Print BoxStart
End If
Next
End Sub
I need to create a macros which removes whitespaces and indent before all paragraphs in the active MS Word document. I've tried following:
For Each p In ActiveDocument.Paragraphs
p.Range.Text = Trim(p.range.Text)
Next p
which sets macros into eternal loop. If I try to assign string literal to the paragraphs, vba always creates only 1 paragraph:
For Each p In ActiveDocument.Paragraphs
p.Range.Text = "test"
Next p
I think I have a general misconception about paragraph object. I would appreciate any enlightment on the subject.
The reason the code in the question is looping is because replacing one paragraph with the processed (trimmed) text is changing the paragraphs collection. So the code will continually process the same paragraph at some point.
This is normal behavior with objects that are getting deleted and recreated "behind the scenes". The way to work around it is to loop the collection from the end to the front:
For i = ActiveDocument.Paragraphs.Count To 1 Step -1
Set p = ActiveDocument.Paragraphs(i)
p.Range.Text = Trim(p.Range.Text)
Next
That said, if the paragraphs in the document contain any formatting this will be lost. String processing does not retain formatting.
An alternative would be to check the first character of each paragraph for the kinds of characters you consider to be "white space". If present, extend the range until no more of these characters are detected, and delete. That will leave the formatting intact. (Since this does not change the entire paragraph a "normal" loop works.)
Sub TestTrimParas()
Dim p As Word.Paragraph
Dim i As Long
Dim rng As Word.Range
For Each p In ActiveDocument.Paragraphs
Set rng = p.Range.Characters.First
'Test for a space or TAB character
If rng.Text = " " Or rng.Text = Chr(9) Then
i = rng.MoveEndWhile(" " + Chr(9))
Debug.Print i
rng.Delete
End If
Next p
End Sub
You could, of course, do this in a fraction of the time without a loop, using nothing fancier than Find/Replace. For example:
Find = ^p^w
Replace = ^p
and
Find = ^w^p
Replace = ^p
As a macro this becomes:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
.InsertBefore vbCr
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchWildcards = False
.Text = "^p^w"
.Replacement.Text = "^p"
.Execute Replace:=wdReplaceAll
.Text = "^w^p"
.Execute Replace:=wdReplaceAll
End With
.Characters.First.Text = vbNullString
End With
Application.ScreenUpdating = True
End Sub
Note also that trimming text the way you're doing is liable to destroy all intra-paragraph formatting, cross-reference fields, and the like; it also won't change indents. Indents can be removed by selecting the entire document and changing the paragraph format; better still, modify the underlying Styles (assuming they've been used correctly).
Entering "eternal" loop is a bit unpleasant. Only Chuck Norris can exit one. Anyway, try to make a check before trimming and it will not enter:
Sub TestMe()
Dim p As Paragraph
For Each p In ThisDocument.Paragraphs
If p.Range <> Trim(p.Range) Then p.Range = Trim(p.Range)
Next p
End Sub
As has been said by #Cindy Meister, I need to prevent endless creation of another paragraphs by trimming them. I bear in mind that paragraph range contains at least 1 character, so processing range - 1 character would be safe. Following has worked for me
Sub ProcessParagraphs()
Set docContent = ActiveDocument.Content
' replace TAB symbols throughout the document to single space (trim does not remove TAB)
docContent.Find.Execute FindText:=vbTab, ReplaceWith:=" ", Replace:=wdReplaceAll
For Each p In ActiveDocument.Paragraphs
' delete empty paragraph (delete operation is safe, we cannot enter enternal loop here)
If Len(p.range.Text) = 1 Then
p.range.Delete
' remove whitespaces
Else
Set thisRg = p.range
' shrink range by 1 character
thisRg.MoveEnd wdCharacter, -1
thisRg.Text = Trim(thisRg.Text)
End If
p.LeftIndent = 0
p.FirstLineIndent = 0
p.Reset
p.range.Font.Reset
Next
With Selection
.ClearFormatting
End With
End Sub
I saw a number of solutions here are what worked for me. Note I turn off track changes and then revert back to original document tracking status.
I hope this helps some.
Option Explicit
Public Function TrimParagraphSpaces()
Dim TrackChangeStatus: TrackChangeStatus = ActiveDocument.TrackRevisions
ActiveDocument.TrackRevisions = False
Dim oPara As Paragraph
For Each oPara In ActiveDocument.StoryRanges(wdMainTextStory).Paragraphs
Dim oRange As Range: Set oRange = oPara.Range
Dim endRange, startRange As Range
Set startRange = oRange.Characters.First
Do While (startRange = Space(1))
startRange.Delete 'Remove last space in each paragraphs
Set startRange = oRange.Characters.First
Loop
Set endRange = oRange
' NOTE: for end range must select the before last characted. endRange.characters.Last returns the chr(13) return
endRange.SetRange Start:=oRange.End - 2, End:=oRange.End - 1
Do While (endRange = Space(1))
'endRange.Delete 'NOTE delete somehow does not work for the last paragraph
endRange.Text = "" 'Remove last space in each paragraphs
Set endRange = oPara.Range
endRange.SetRange Start:=oRange.End - 1, End:=oRange.End
Loop
Next
ActiveDocument.TrackRevisions = TrackChangeStatus
End Function
Is there a direct way that we can split a word revision in to set of revisions?
If cannot, In this below case,
This is related to my other issue.
The document has several paragraphs with each has its own applied style.
When take the inserted revision in the above example, I want to separate the revision by the inserted paragraph ending marks as then it will split into three revisions. And the solution should be a global solution which can be able to apply for any insertion whatever the user does.
For example :
Insertion can contain any number of paragraph ending marks within it.
Insertion can start with a paragraph ending mark
Paragraphs has separate paragraph styles applied and we need to keep them unchanged.
This is the code I have modified,I tried to separate the first paragraph and other paragraphs. But, I have stuck in the logic part.
Private Function RemoveParagraphEndingsFromRevisions(ByRef WordRange As Word.Range)
On Error GoTo ErrorHandler
Dim fTrackRevisions As Boolean
Dim objRevision As Word.Revision
Dim objRange1, objRange2 As Word.Range
Dim sPara, firstParaStyle As String
Dim stylesCollection As VBA.Collection
Dim count As Long
Set stylesCollection = New VBA.Collection
sPara = vbCr
With WordRange.Document
fTrackRevisions = .TrackRevisions
.TrackRevisions = False
End With
For Each objRevision In WordRange.Document.Revisions
'AllowTrackChangesForInsertion method checks whether the revision contains a text change
If AllowTrackChangesForInsertion(objRevision) = True Then
'If there are paragraph ending marks within the revision
If InStr(objRevision.Range.Text, sPara) > 0 Then
Set objRange1 = objRevision.Range.Duplicate
Set objRange2 = objRange1.Duplicate
firstParaStyle = objRange2.Paragraphs(1).Style
If (objRange1.Paragraphs.count > 1) Then
count = 2
Do While (count < objRange1.Paragraphs.count + 1)
stylesCollection.Add objRange1.Paragraphs(count).Style
count = count + 1
Loop
.........
Else
'When there's no inserted text after inserted end para mark
End If
End If
End If
Next
ErrorHandler:
WordRange.Document.TrackRevisions = fTrackRevisions
Set objRevision = Nothing
Set objRange1 = Nothing
Set objRange2 = Nothing
Set stylesCollection = Nothing
Select Case Err.Number
Case 0
Case Else
ShowUnexpectedError ErrorSource:="RemoveParasFromRevisions" & vbCr & Err.Source
End Select
End Function
Could anybody please help me with this.
Thank you.
I have able to implement a code that split a revision into revisions when have paragraph ending marks within it along with there applied styles.
Any improvements for this code snippet are really appreciated.
Private Function RemoveParagraphEndingsFromRevisions(ByRef WordRange As Word.Range)
On Error GoTo ErrorHandler
Dim fTrackRevisions As Boolean
Dim objRevision As Word.Revision
Dim objRange1 As Word.Range
Dim sPara As String
Dim firstParaStyle As String
Dim objParagraph As Word.Paragraph
sPara = vbCr
With WordRange.Document
fTrackRevisions = .TrackRevisions
.TrackRevisions = False
End With
For Each objRevision In WordRange.Document.Revisions
If AllowTrackChangesForInsertion(objRevision) = True Then
'does the revision contains paragraph ending marks within it
If InStr(objRevision.Range.Text, sPara) > 0 Then
Set objRange1 = objRevision.Range.Duplicate
Set objParagraph = objRange1.Paragraphs.First
'Get the styles of the first paragraph of the revision
firstParaStyle = objRange1.Paragraphs.First.Style
objParagraph.Range.Collapse wdCollapseEnd
'Insert another paragraph as "buffer"
objParagraph.Range.InsertAfter sPara
'Ensure the first paragraph has its original style
objRange1.Paragraphs.First.Style = firstParaStyle
'Delete the "buffer" paragraph
objParagraph.Range.MoveStart wdCharacter, 1
objParagraph.Range.Characters.Last.Delete
End If
End If
Next
ErrorHandler:
WordRange.Document.TrackRevisions = fTrackRevisions
Set objRevision = Nothing
Set objRange1 = Nothing
Set objParagraph = Nothing
Select Case Err.Number
Case 0
Case Else
ShowUnexpectedError ErrorSource:="RemoveParasFromRevisions" & vbCr & Err.Source
End Select
End Function
I wrote a macro to delete all the empty paragraphs in my document, but it exhibits weird behavior: If there are a number of empty paragraphs at the very end of the document, about half of them are deleted. Repeatedly running the macro gradually eliminates the empty paragraphs until only one empty paragraph remains. Even if there is a boundary condition so that I need a line of code to delete the last paragraph, but I still don't understand why only half of the empty paragraphs at the end are deleted. Can anyone explain why this is happening and how to correct this behavior? As an aside, I searched online and saw numerous posts about detecting paragraph markers (^p, ^13, and others, but only searching vbCr worked, which is another minor puzzle.)
Sub Delete_Empty__Paras_2() 'This macro looks for empty paragraphs and deletes them.
Dim original_num_of_paras_in_doc As Integer
Dim num_of_deleted_paras As Integer
original_num_of_paras_in_doc = ActiveDocument.Paragraphs.Count 'Count the number of paragraphs in the document to start
num_of_deleted_paras = 0 'In the beginning, no paragraphs have been deleted
Selection.HomeKey Unit:=wdStory 'Go to the beginning of the document.
For current_para_number = 1 To original_num_of_paras_in_doc 'Process each paragraph in the document, one by one.
If current_para_number + num_of_deleted_paras > original_num_of_paras_in_doc Then 'Stop processing paragraphs when the loop has processed every paragraph.
Exit For
Else 'If the system just deleted the 3rd paragraph of the document because
' it's empty, the next paragraph processed is the 3rd one again,
'so when we iterate the counter, we have to subtract the number of deleted paragraphs to account for this.
Set paraRange = ActiveDocument.Paragraphs(current_para_number - num_of_deleted_paras).Range
paratext = paraRange.Text
If paratext = vbCr Then 'Is the paragraph empty? (By the way, checking for vbCr is the only method that worked for checking for empty paras.)
paratext = "" 'Delete the paragraph.
ActiveDocument.Paragraphs(current_para_number - num_of_deleted_paras).Range.Text = paratext
num_of_deleted_paras = num_of_deleted_paras + 1 'Iterate the count of deleted paras.
End If
End If
Next current_para_number
End Sub
This code will delete all blank paragraphs...
Sub RemoveBlankParas()
Dim oDoc As Word.Document
Dim i As Long
Dim oRng As Range
Dim lParas As Long
Set oDoc = ActiveDocument
lParas = oDoc.Paragraphs.Count ' Total paragraph count
Set oRng = ActiveDocument.Range
For i = lParas To 1 Step -1
oRng.Select
lEnd = lEnd + oRng.Paragraphs.Count ' Keep track of how many processed
If Len(ActiveDocument.Paragraphs(i).Range.Text) = 1 Then
ActiveDocument.Paragraphs(i).Range.Delete
End If
Next i
Set para = Nothing
Set oDoc = Nothing
Exit Sub
End Sub
You can replace the paragraph marks:
ActiveDocument.Range.Find.Execute FindText:="^p^p", ReplaceWith:="^p", Replace:=wdReplaceAll
ActiveDocument.Range.Find.Execute "^p^p", , , , , , , , , "^p", wdReplaceAll ' might be needed more than once