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

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