How to efficiently loop through paragraphs and make simple changes with Word VBA (Specially reverse loop to Delete Paragraphs)
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 &lt; .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 &gt; 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 &amp; "/" &amp; PrCnt
        End If
    i = i + 1
    Next
Debug.Print " paragraph to delete:" &amp; DelCnt
Debug.Print " Seconds taken to Calc:" &amp; 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 " &amp; i &amp; "/" &amp; Timer - tm
        End If
        End If
    Next

End With

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

TurnOn
Debug.Print " pagination Completed:"
Debug.Print " Seconds taken:" &amp; 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