Sub открыть()

    Dim objWrdApp As Object
    Dim objWrdDoc As Object

    On Error Resume Next
    Set objWrdApp = GetObject(, "Word.Application")
    If objWrdApp Is Nothing Then
        Set objWrdApp = CreateObject("Word.Application")
        Set objWrdDoc = objWrdApp.Documents.Open("C:\word.rtf")
        objWrdApp.Visible = True
    End If
    Set objWrdDoc = objWrdApp.Documents.Open("C:\word.rtf")

    ReplacementText = Лист1.[H3]
   
    With objWrdApp.Selection
        .HomeKey Unit:=6
        .Find.ClearFormatting
        With .Find
            .Text = "Вот этот текст нужно удалить "
            .Forward = True
            .Wrap = 0
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchControl = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        With objWrdApp.Selection
            If Not .Find.Execute Then Exit Sub
            objWrdApp.Selection.SelectCell
            objWrdApp.Selection.Text = Left(objWrdApp.Selection, InStr(objWrdApp.Selection, "Вот этот текст нужно удалить ") - 1) & "Вот этот текст нужно удалить "
            objWrdApp.Selection.Next(Unit:=10).Select
            objWrdApp.Selection.EndKey Unit:=6, Extend:=1
            objWrdApp.Selection.Delete
        End With

        With objWrdDoc.Content.Find
            .Text = "Вот этот текст нужно удалить "
            .Replacement.Text = ReplacementText
            .Forward = True
            .Wrap = 0
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchControl = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Execute Replace:=2, Forward:=True, Wrap:=1
        End With
    End With
End Sub