Restricting action to a selection

[Chuck]

Hi,

I regularly receive large documents (hundreds of pages each) that need
re-formatting. I need a macro to automate the re-formatting, but the recorded
versions do not work. For example, I need to select paragraphs on the basis
of the first two characters in the paragraph, then replace every comma in the
paragraph (or semicolon in different set of paragraphs) with a ^p . However,
when the macro is run, every comma in the document is replaced, I presume
because the action of creating a new paragraph removes the selection.

Any suggestions on this will be appreciated. My current code is below:

Sub CitationFix()
'
' CitationFix Macro
'
'
Selection.Find.ClearFormatting
With Selection.Find
.Text = "^pDE "
.Replacement.Text = "^p "
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = ", "
.Replacement.Text = "^p "
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub

 

[Pesach Shelnitz]

If I understood correctly what you want to accomplish, this macro should do
it for you.

Sub CitationFix()
Dim myRange As Range
Dim i, pos1, pos2 As Integer

i = 1
Do While i <= ActiveDocument.Paragraphs.Count
With ActiveDocument.Paragraphs(i).Range
If .Characters.Count >= 2 Then
If .Characters(1) = "D" And .Characters(2) = "E" Then
.Characters(1).Delete
.Characters(1).Delete
pos1 = .Start
pos2 = .End
Set myRange = ActiveDocument.Range(Start:=pos1, End:=pos2)
myRange.Find.ClearFormatting
With myRange.Find
.ClearFormatting
.Text = ","
.Replacement.Text = "^p"
.Forward = True
.Wrap = wdFindStop
Do While .Execute(Replace:=wdReplaceOne) = True
myRange.Start = pos1
myRange.End = pos2
i = i + 1
Loop
End With
End If
End If
End With
i = i + 1
Loop
End Sub

 

[Chuck]

Pesach,

Thank you. That code works. Unfortunately, it is very slow as it has to
examine every paragraph in the document. In a small document I tried it on
(143 pages) there are 6100+ paragraphs, only 90 of which begin "DE ". And, I
would need to do that also with paragraphs that begin "DI ". So, going
through 12000+ paragraphs individually is prohibitively time consuming. Can I
search for the strings as before, selecting the paragraph as a range somehow
and use your code for replacing the commas in the range? I don't know how to
get the index of the paragraph the cursor is on.

Thanks,

 

[Pesach Shelnitz]

Hi Chuck,

See if this version does the job any faster. Note that if the first
paragraph begins with DE, this version will skip it because it is not
preceded by ^p.

Sub CitationFix2()
Dim myRange As Range
Dim pos1, pos2 As Integer

Selection.HomeKey wdStory
With Selection.Find
.ClearFormatting
.Text = "^pDE"
.Replacement.Text = "^p"
.Forward = True
.Wrap = wdFindStop
Do While .Execute(Replace:=wdReplaceOne) = True
Selection.Collapse Direction:=wdCollapseEnd
With Selection.Paragraphs.First.Range
pos1 = .Start
pos2 = .End
Set myRange = ActiveDocument.Range(Start:=pos1, End:=pos2)
myRange.Find.ClearFormatting
With myRange.Find
.ClearFormatting
.Text = ","
.Replacement.Text = "^p"
.Forward = True
.Wrap = wdFindStop
Do While .Execute(Replace:=wdReplaceOne) = True
myRange.Start = pos1
myRange.End = pos2
Loop
End With
End With
Loop
End With
End Sub

 

[Chuck]

Terrific. That works extremely well. I had to make one change - I dimensioned
pos1 and pos2 as longs because of an overflow error that occurred when they
were dimensioned as integers. I hope to be able to get the rest of the
re-formatting working just as well.

Thank you for the code!

 

[Jean-Guy Marcil]

Chuck was telling us:
Chuck nous racontait que :

Terrific. That works extremely well. I had to make one change - I
dimensioned pos1 and pos2 as longs because of an overflow error that
occurred when they were dimensioned as integers. I hope to be able to
get the rest of the re-formatting working just as well.

Thank you for the code!

Indeed, Integers are deprecated.

Also, note that in the above code, pos1 is a variant.


Try this variation, it may run little faster since it does not use the
Selection object:

Dim myRange As Range

Set myRange = ActiveDocument.Range

With myRange.Find
.Text = "^pDE"
.Replacement.Text = "^p"
Do While .Execute(Replace:=wdReplaceOne) = True
With myRange.Paragraphs(1).Next.Range
With .Find
.Text = ","
.Replacement.Text = "^p"
.Execute Replace:=wdReplaceAll
End With
myRange.SetRange myRange.End, ActiveDocument.Range.End
End With
Loop
End With