Paragraph Smasher Macro--to Improve?

D

David Godinger

Hi,

I've written a VBA script (for Microsoft Word 2000 on the PC) that
highlights the current paragraph, then breaks it up into sentences that are
separated by paragraph marks. Now the author can analyze the structure of
the writing, and move the sentences around.

The script adds double paragraph marks after "." "!" "?" and ";".
Afterwards, it also removes the new, unnecessary paragraph marks after
"Mr." "Ms." "Mrs." "a.m." and "p.m." However, it doesn't fix other
abbreviations.

I was wondering if someone can improve this macro.

Thanks.

Here's the script.
- - -

Sub Paragraph_Smasher()
'
' Paragraph_Smasher Macro breaks up a paragraph to help you see each
sentence

' Select the current Paragraph
Selection.StartOf Unit:=wdParagraph
Selection.MoveEnd Unit:=wdParagraph

' Put double paragraph marks after periods
Do
Selection.Find.ClearFormatting
' Use the Find object to search for text.
With Selection.Find
.Text = ". "
' Use the replacement object to replace text.
.Replacement.Text = "~.~^p^p"
.Execute Replace:=wdReplaceAll, Forward:=True
End With
' If no more occurrences, exit the loop.
If Selection.Find.Execute = False Then Exit Do
Loop

Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "~.~"
.Replacement.Text = "."
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

' Remove paragraph marks after instances of "Mr." "Ms." Mrs."
Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "Mr.^p^p"
.Replacement.Text = "Mr. "
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "Ms.^p^p"
.Replacement.Text = "Ms. "
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "Mrs.^p^p"
.Replacement.Text = "Mrs. "
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

' Put instances of a.m. and p.m. back together
Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "a.^pm.^p"
.Replacement.Text = "a.m.^p"
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "p.^pm.^p"
.Replacement.Text = "p.m.^p"
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

' Put paragraph marks after exclamation marks
Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "! "
.Replacement.Text = "~!~^p^p"
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "~!~"
.Replacement.Text = "!"
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

' Put paragraph marks after question marks
Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "? "
.Replacement.Text = "~?~^p^p"
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "~?~"
.Replacement.Text = "?"
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

' Put paragraph marks after semicolons
Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "; "
.Replacement.Text = "~;~^p^p"
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "~;~"
.Replacement.Text = ";"
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

End Sub
 
J

Jezebel

Here's an entirely different approach. I think it has a maintainability
advantage over your approach, in that all the tests are in the one spot.
You'll need to tweak the tests in the middle for what constitutes a 'real'
sentence -- there are still plenty of holes, like sentences that terminate
with parantheses and quotation marks.



Dim pSentence As Word.Range
Dim pWord As String
Dim pWordCount As Long
Dim pFlag As Boolean

'Check each 'sentence' in the document
For Each pSentence In ActiveDocument.Sentences

'Do nothing if it's already the last in a paragraph
If Right(pSentence, 1) <> vbCr Then

'Get the number of 'words' in the sentence
pWordCount = pSentence.Words.Count

'Ignore single-word sentences (the 'word' is the punctuation
mark)
If pWordCount > 1 Then

'Get the last actual word
pWord = Trim(pSentence.Words(pWordCount - 1).Text)

'Process this paragraph unless it fails one of the tests
pFlag = True

'If it's only one text character, this is probably an
abbreviation
If pWord Like "[A-Za-z0-9]" Then
pFlag = False

'Known abbreviations ... many more to add here
ElseIf pWord = "Mr" Or _
pWord = "Mrs." Then
pFlag = False
End If

'Replace the terminating space with a paragraph mark
If pFlag Then
pSentence = Left(pSentence, Len(pSentence) - 1) & vbCr
End If

End If
End If
Next


David Godinger said:
Hi,

I've written a VBA script (for Microsoft Word 2000 on the PC) that
highlights the current paragraph, then breaks it up into sentences that are
separated by paragraph marks. Now the author can analyze the structure of
the writing, and move the sentences around.

The script adds double paragraph marks after "." "!" "?" and ";".
Afterwards, it also removes the new, unnecessary paragraph marks after
"Mr." "Ms." "Mrs." "a.m." and "p.m." However, it doesn't fix other
abbreviations.

I was wondering if someone can improve this macro.

Thanks.

Here's the script.
- - -

Sub Paragraph_Smasher()
'
' Paragraph_Smasher Macro breaks up a paragraph to help you see each
sentence

' Select the current Paragraph
Selection.StartOf Unit:=wdParagraph
Selection.MoveEnd Unit:=wdParagraph

' Put double paragraph marks after periods
Do
Selection.Find.ClearFormatting
' Use the Find object to search for text.
With Selection.Find
.Text = ". "
' Use the replacement object to replace text.
.Replacement.Text = "~.~^p^p"
.Execute Replace:=wdReplaceAll, Forward:=True
End With
' If no more occurrences, exit the loop.
If Selection.Find.Execute = False Then Exit Do
Loop

Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "~.~"
.Replacement.Text = "."
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

' Remove paragraph marks after instances of "Mr." "Ms." Mrs."
Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "Mr.^p^p"
.Replacement.Text = "Mr. "
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "Ms.^p^p"
.Replacement.Text = "Ms. "
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "Mrs.^p^p"
.Replacement.Text = "Mrs. "
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

' Put instances of a.m. and p.m. back together
Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "a.^pm.^p"
.Replacement.Text = "a.m.^p"
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "p.^pm.^p"
.Replacement.Text = "p.m.^p"
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

' Put paragraph marks after exclamation marks
Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "! "
.Replacement.Text = "~!~^p^p"
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "~!~"
.Replacement.Text = "!"
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

' Put paragraph marks after question marks
Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "? "
.Replacement.Text = "~?~^p^p"
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "~?~"
.Replacement.Text = "?"
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

' Put paragraph marks after semicolons
Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "; "
.Replacement.Text = "~;~^p^p"
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "~;~"
.Replacement.Text = ";"
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

End Sub
Click to expand...
Martin King
 
D

David Godinger

Hi Jezebel,

Your script seems to be a great improvement over mine, and it works very
well. However, it looks like I need to study VBA syntax a lot more to
understand what you did!

Question: Can it be changed to work only in the current paragraph?

Thanks.


Jezebel said:
Here's an entirely different approach. I think it has a maintainability
advantage over your approach, in that all the tests are in the one spot.
You'll need to tweak the tests in the middle for what constitutes a 'real'
sentence -- there are still plenty of holes, like sentences that terminate
with parantheses and quotation marks.



Dim pSentence As Word.Range
Dim pWord As String
Dim pWordCount As Long
Dim pFlag As Boolean

'Check each 'sentence' in the document
For Each pSentence In ActiveDocument.Sentences

'Do nothing if it's already the last in a paragraph
If Right(pSentence, 1) <> vbCr Then

'Get the number of 'words' in the sentence
pWordCount = pSentence.Words.Count

'Ignore single-word sentences (the 'word' is the punctuation
mark)
If pWordCount > 1 Then

'Get the last actual word
pWord = Trim(pSentence.Words(pWordCount - 1).Text)

'Process this paragraph unless it fails one of the tests
pFlag = True

'If it's only one text character, this is probably an
abbreviation
If pWord Like "[A-Za-z0-9]" Then
pFlag = False

'Known abbreviations ... many more to add here
ElseIf pWord = "Mr" Or _
pWord = "Mrs." Then
pFlag = False
End If

'Replace the terminating space with a paragraph mark
If pFlag Then
pSentence = Left(pSentence, Len(pSentence) - 1) & vbCr
End If

End If
End If
Next


David Godinger said:
Hi,

I've written a VBA script (for Microsoft Word 2000 on the PC) that
highlights the current paragraph, then breaks it up into sentences that are
separated by paragraph marks. Now the author can analyze the structure of
the writing, and move the sentences around.

The script adds double paragraph marks after "." "!" "?" and ";".
Afterwards, it also removes the new, unnecessary paragraph marks after
"Mr." "Ms." "Mrs." "a.m." and "p.m." However, it doesn't fix other
abbreviations.

I was wondering if someone can improve this macro.

Thanks.

Here's the script.
- - -

Sub Paragraph_Smasher()
'
' Paragraph_Smasher Macro breaks up a paragraph to help you see each
sentence

' Select the current Paragraph
Selection.StartOf Unit:=wdParagraph
Selection.MoveEnd Unit:=wdParagraph

' Put double paragraph marks after periods
Do
Selection.Find.ClearFormatting
' Use the Find object to search for text.
With Selection.Find
.Text = ". "
' Use the replacement object to replace text.
.Replacement.Text = "~.~^p^p"
.Execute Replace:=wdReplaceAll, Forward:=True
End With
' If no more occurrences, exit the loop.
If Selection.Find.Execute = False Then Exit Do
Loop

Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "~.~"
.Replacement.Text = "."
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

' Remove paragraph marks after instances of "Mr." "Ms." Mrs."
Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "Mr.^p^p"
.Replacement.Text = "Mr. "
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "Ms.^p^p"
.Replacement.Text = "Ms. "
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "Mrs.^p^p"
.Replacement.Text = "Mrs. "
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

' Put instances of a.m. and p.m. back together
Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "a.^pm.^p"
.Replacement.Text = "a.m.^p"
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "p.^pm.^p"
.Replacement.Text = "p.m.^p"
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

' Put paragraph marks after exclamation marks
Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "! "
.Replacement.Text = "~!~^p^p"
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "~!~"
.Replacement.Text = "!"
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

' Put paragraph marks after question marks
Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "? "
.Replacement.Text = "~?~^p^p"
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "~?~"
.Replacement.Text = "?"
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

' Put paragraph marks after semicolons
Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "; "
.Replacement.Text = "~;~^p^p"
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = "~;~"
.Replacement.Text = ";"
.Execute Replace:=wdReplaceAll, Forward:=True
End With
If Selection.Find.Execute = False Then Exit Do
Loop

End Sub
Click to expand...
Martin King
Click to expand...
 
J

Jezebel

Question: Can it be changed to work only in the current paragraph?
Click to expand...

Sure. Every range has a sentences property, so you could insert any range in
place of 'ActiveDocument', eg

For each pSentence in Selection.Paragraphs(1).Sentences
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Change a great number of words in word files, with a macro as short as possible. 5
Select Text to End of Footnote 9
Loop until end 1
Word macro that can call cells out of Excel for a find and replace 0
CleanUpPastedText() 1
Need help modifying code 0
Find/Replace macro only limited to selection when entire paragraphis selected 22
count a string within a selected text 1

Top