# How to efficiently loop through paragraphs and make simple changes with Word VBA (Specially reverse loop to Delete Paragraphs)

This is regarding my answer with SO post How to remove paragraph marks with different format in MS-Word. My primary question, is there any way performance of the code could be improved to operate on document as intended by OP (2.2 MB and has 2.1K pages, 871K words, 4,6M characters including spaces)?
On Secondary, is there a simple way or workaround that I am missing (and making things unnecessary complicated) to perform the sane task efficiently?

Here I reproduce my code after adding some futile measures to improve performance of the code with file of the size specified by the OP.

    Option Explicit
Sub ReplacePara()
Dim Para As Paragraph, Xstr As String, Rng As Range
Dim i As Long, ln As Long, tm As Double, PrCnt As Long
Dim PrvChrSize As Integer, NextChrSize  As Integer
Dim PrvChrFont As String, NextChrFont  As String
Dim PrvChrItalic As Boolean, NextChrItalic As Boolean
tm = Timer

‘Following measures added to improve performance
‘but on the contrary it’s found instead of increasing time taken
Application.ScreenUpdating = False
With Options
.Pagination = False
.CheckSpellingAsYouType = False
.CheckGrammarAsYouType = False
End With

With ActiveDocument
PrCnt = .Paragraphs.Count
Debug.Print PrCnt
For i = .Paragraphs.Count To 1 Step -1
Set Para = .Paragraphs(i)
ln = Para.Range.Characters.Count

If ln > 1 Then
With Para.Range.Characters(ln - 1).Font
PrvChrSize = .Size
PrvChrFont = .Name
PrvChrItalic = .Italic
End With

If i < .Paragraphs.Count Then
With .Paragraphs(i + 1).Range.Characters(1).Font
NextChrSize = .Size
NextChrFont = .Name
NextChrItalic = .Italic
End With
Else
NextChrSize = 0
NextChrFont = ""
NextChrItalic = False
End If
End If

'Debug.Print i, PrvChrSize, PrvChrFont, NextChrSize, NextChrFont
If (PrvChrSize = 15 And (PrvChrFont = "Arial" Or PrvChrItalic = True)) _
And (NextChrSize = 15 And (NextChrFont = "Arial" Or NextChrItalic)) Then
Para.Range.Characters(ln).Text = " "
End If
.UndoClear
'If PrCnt < 1000 Then Debug.Print i & "/" & PrCnt
Next
End With

With Options
.Pagination = True
.CheckSpellingAsYouType = True
.CheckGrammarAsYouType = True
End With
Application.ScreenUpdating = True
Debug.Print " Seconds taken:" & Timer - tm
End Sub


The added measures actually found to increase time taken (from 3 odd minutes to 4 odd minutes) with documents of 124 pages. I haven’t ventured far to go for LockWindowUpdate API.

Though the code tested Ok with documents of 100 pages around. I could not finish the task with a makeshift giant file of around 2.4 K pages. It is virtually crashing Word (not recovering from ‘Not responding mode’). I ceated the file with a simple code stub with the sample file linked by OP in the SO post. Code stub was also produced for ease is testing.

Sub makebig()
Dim Rng As Range, MyRange As Range
Dim Wd As Document
Dim i  As Long
Set Wd = ThisDocument
Set Rng = Wd.Content
Rng.Copy

For x = 1 To 2000
Set MyRange = Wd.Content
MyRange.EndOf Unit:=wdStory, Extend:=wdMove
MyRange.Paste
Next
End Sub


Running the code with sample file twice (1st time with For x = 1 To 2000 and second time with For x = 1 To 1) will produce a file about 2.4 K pages. For getting a file of 124 pages from the sample file 200 loops are sufficient.

• first step would be to understand where your code fails? Does it just take too long to go through the document? Is there an issue deleting paragraph marks? Does disabling pagination already take too long? ... I suggest first to debug your code through some paragraphs and see whether any step take unexpectedly long. Second step would be to run the code only on small portion of the document (e.g.  For i = .Paragraphs.Count To .Paragraphs.Count - 100 Step -1) to see whether it can manage the document itself. – Máté Juhász Jun 27 at 10:03
• If both are successful then maybe deleting the linebreak is the issue (need to change number of paragraph, restructure everything...), just try to run the code without actually deleting anything ... – Máté Juhász Jun 27 at 10:04
• @Máté Juhász thank you for kind attention on the problem and sorry for delayed response. Tried suggested way to work only on last 100 paragraphs. With multiple try with 2.4 k pg & 56 K paragraphs only once succeed to come out without getting trapped in non-response state. On the test with pagination etc off code come out normally at 7 odd sec, but while checking the document manually could not the find paragraphs replaced. On another test with pagination etc On, paragraphs replacement is witnessed onscreen while code is running but finally became non responsive. – Ahmed AU Jun 28 at 9:14
• Unfortunately it seems that Word just can't manage that big document. Maybe you can split it before processing. – Máté Juhász Jun 28 at 11:19
• Try using a For Each loop instead of using by index. It should be faster iterating over a collection with for each vs index. – Ryan Wildry Jun 28 at 11:40

Answering my Own question to share with community the Height of stupidity in my code and gradually how over 1 or 2 sleepless nights of testing, the problem was reduce to workable.

First the height of stupidity is the line

     If i < .Paragraphs.Count Then


even after knowing well that while working with such giant document interaction with document is to keep minimum, I resorted to .Paragraphs.Count in every loop of 56 K paragraphs. Whereas .Paragraphs.Count had already been assigned to variable PrCnt. Also the If is used to only avoid the error trying to access next para while in the last loop of paragraphs and intended to act once only.

Replacing it with 'PrCnt make the code somehow stable and could run through the code while disabling write on the document.

Next Thanks to @Ryan Wildry suggestion and tried to go for For Each Loop. Since I am deleting paragraph marks. I tried to go for a Forward For Each loop and test the conditions and take the paragraphs number of the paragraphs to be deleted to a Array. This loop takes only 1-2 minutes to collect the desired information form 56 K paras.

Now after completing the loop, started replacing the paragraphs in reveres loop in this fashion

 For i = UBound(ParaNumToDelete) To 1 Step -1
.Paragraphs(ParaNumToDelete(i)).Range.Characters(LnArr(i)).Text = " "


but this also found taking around 6-7 hours to complete 2.4 K page 56 K paragraphs (and 16 k paragraphs marks to replace) document. 150 seconds to replace 50 paragraphs in the start loop (i.e. near bottom of documents) and hardly 1-2 seconds do replace 50 paragraphs at the end of loop (i.e. near start of the document). Code execution is unstable and feared to be in Non Responding state even with single click.

So one more measures added to Save the document at say every 200 replacement, so code could be run again to complete the uncompleted task any time later.

Finally again thanks to @Ryan Wildry's comment and a Range Array was created in the First For Each loop (taking 1-2 minutes) and next the range array was iterated in reverse order to replace paragraph marks. It takes only around 10 minutes to complete without save (or around 15 minutes with save at 200 replacement)

The final code:

Sub TestPara()
Dim Para As Paragraph, PrvLn As Long, xRng As Range, PrvRng As Range
Dim i As Long, ln As Long, tm As Double, PrCnt As Long
Dim ChrSize As Integer, PrvChrSize  As Integer, LastChrSize As Integer
Dim ChrFont As String, PrvChrFont  As String, LastChrFont As String
Dim ChrItalic As Boolean, PrvChrItalic As Boolean, LastChrItalic As Boolean
Dim OnOff As Boolean, DelCnt As Long, DoSave As Boolean
Dim RngArr() As Range, Pos As Long
tm = Timer

TurnOn False

With ActiveDocument
PrCnt = .Paragraphs.Count
Debug.Print PrCnt
DelCnt = 0
PrvChrSize = 0
PrvChrFont = 0
PrvChrItalic = False
PrvLn = 0
i = 1

For Each Para In .Paragraphs
ln = Para.Range.Characters.Count
Pos = Para.Range.End
Set xRng = ActiveDocument.Range(Pos - 1, Pos)

If ln > 1 Then
With Para.Range.Characters(ln - 1).Font
LastChrSize = .Size
LastChrFont = .Name
LastChrItalic = .Italic
End With

With Para.Range.Characters(1).Font
ChrSize = .Size
ChrFont = .Name
ChrItalic = .Italic
End With
Else
LastChrSize = 0
LastChrFont = 0
LastChrItalic = False
ChrSize = 0
ChrFont = 0
ChrItalic = False
End If

If (ChrSize = 15 And ChrFont = "Arial" And ChrItalic) _
And (PrvChrSize = 15 And PrvChrFont = "Arial" And PrvChrItalic) Then
DelCnt = DelCnt + 1
ReDim Preserve RngArr(1 To DelCnt)
Set RngArr(DelCnt) = PrvRng
End If

PrvChrSize = LastChrSize
PrvChrFont = LastChrFont
PrvChrItalic = LastChrItalic
PrvLn = ln
Set PrvRng = xRng

If i Mod 2000 = 0 Then
Debug.Print i & "/" & PrCnt
End If
i = i + 1
Next
Debug.Print " paragraph to delete:" & DelCnt
Debug.Print " Seconds taken to Calc:" & Timer - tm

TurnOn False
DoSave = True

For i = UBound(RngArr) To 1 Step -1
RngArr(i).Text = " "

If i Mod 1000 = 0 Then
.UndoClear
DoEvents
Debug.Print i, Timer - tm
End If

If DoSave Then
If i Mod 200 = 0 Then
.Save
DoEvents
Debug.Print "Save at delete Countdown " & i & "/" & Timer - tm
End If
End If
Next

End With

Debug.Print "  Delete completed in Seconds:" & Timer - tm

TurnOn
Debug.Print " pagination Completed:"
Debug.Print " Seconds taken:" & Timer - tm
End Sub
Sub TurnOn(Optional OnOff As Boolean = True)
Application.ScreenUpdating = OnOff
With Options
.Pagination = OnOff
.CheckSpellingAsYouType = OnOff
.CheckGrammarAsYouType = OnOff
End With
End Sub
`

Hope my ordeal will help the community in similar situation