Sub InsertText()
Dim Shp As Shape, Doc As Document, strTextToInsert As String, strTextToFind As String
Dim i As Long, docToOpen As FileDialog, sHght As Single
Dim rngToSearch As Word.Range
Dim DataObj As New MSForms.DataObject
    
    On Error GoTo Err_Exit
    'strText = InputBox("New Text", "Header Textbox Update", "New Text")
    
    ' Switch off the updates of screen
    Application.ScreenUpdating = False
    
    ' Set the text
    strTextToInsert = "Annual bonus rates for the last five years"
    strTextToFind = "Discharge Pack"
    
    DataObj.SetText strTextToInsert
    DataObj.PutInClipboard
    
    Set docToOpen = Application.FileDialog(msoFileDialogFilePicker)
    docToOpen.Show
    For i = 1 To docToOpen.SelectedItems.Count
        'Open each document
        Set Doc = Documents.Open(FileName:=docToOpen.SelectedItems(i))
            Selection.Find.ClearFormatting
        With Selection.Find
            .Text = strTextToFind
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        Selection.Find.Execute
        Selection.MoveRight Unit:=wdCharacter, Count:=1
        Selection.TypeParagraph
        Selection.PasteAndFormat (wdListCombineWithExistingList)
        ' The above inserts a line which creates a second page, so delete a line after
        Selection.EndKey Unit:=wdStory
        Selection.Delete Unit:=wdCharacter, Count:=1

        ActiveDocument.Close SaveChanges:=wdSaveChanges
    Next
    
    Set docToOpen = Nothing: Set Doc = Nothing
    ' Switch Screen updates back on
    Application.ScreenUpdating = True
    Exit Sub
Err_Exit:
    MsgBox Err.Description & Err.Number
End Sub

Sub InsertText()
Dim Doc As Document, strTextToInsert As String, strTextToFind As String
Dim i As Long, docToOpen As FileDialog, sHght As Single
Dim rngToSearch As Word.Range
Dim oFrm As frmProgress
Dim PortionDone As Double

    On Error GoTo Err_Exit

    strTextToInsert = "Annual bonus rates for the last five years"
    strTextToFind = "Discharge Pack"

    Set docToOpen = Application.FileDialog(msoFileDialogFilePicker)
    If docToOpen.Show = -1 Then
        Set oFrm = New frmProgress
        If docToOpen.SelectedItems.Count > 1 Then oFrm.Show vbModeless
        Application.ScreenUpdating = False
        For i = 1 To docToOpen.SelectedItems.Count
            If docToOpen.SelectedItems.Count > 1 Then
                PortionDone = i / docToOpen.SelectedItems.Count
                oFrm.lblProgress.Width = oFrm.fmeProgress.Width * PortionDone
                oFrm.Caption = "Processing document " & i - 1 & " of " & docToOpen.SelectedItems.Count
            End If
            'Open each document
            Set Doc = Documents.Open _
                      (FileName:=docToOpen.SelectedItems(i), _
                       Visible:=False, _
                       AddtoRecentFiles:=False)
            Set rngToSearch = Doc.Range
            With rngToSearch.Find
                Do While .Execute(FindText:=strTextToFind, MatchCase:=True)
                    rngToSearch.Collapse 0
                    rngToSearch.Text = vbCr & strTextToInsert
                    rngToSearch.Collapse 0
                    Exit Do    'If you only want to process the first instance
                Loop
            End With
            Doc.Close SaveChanges:=wdSaveChanges
            DoEvents
        Next
        Unload oFrm
        Application.ScreenUpdating = True
        MsgBox "Processing complete"
    End If
lbl_Exit:
    Set Doc = Nothing
    Set docToOpen = Nothing
    Set rngToSearch = Nothing
    Exit Sub
Err_Exit:
    MsgBox Err.Description & Err.Number
    Err.Clear
    GoTo lbl_Exit
End Sub