Sub согласие()
Dim nDoc&, nDoc0&, wa As Object, wd As Object, myWord As Boolean, marker1
  On Error Resume Next
  Set wa = GetObject(, "Word.Application")            'Пытаемся подключиться к открытому приложению Word
  If Err Then                                         'нет открытого Word
    Err.Clear
    Set wa = CreateObject("Word.Application")         ' Создаем приложение Word
    If Err Then
      MsgBox "Не удалось создать приложение Word", vbCritical
      Exit Sub
    End If
    myWord = True
  End If
  wa.Visible = True                                   'делаем Word видимым
  nDoc0 = wa.documents.Count                          'число документов в приложении Word до
  Sheets("Лист2").OLEObjects(1).Verb
  nDoc = wa.documents.Count                           'число документов в приложении Word после
  If nDoc = nDoc0 + 1 Then                            'мы контролируем правильный Word!
    Set wd = wa.documents(nDoc)
    marker1 = "в"
    wd.Bookmarks.Item(marker1).Range.Text = "hi!!!"
    wd.SaveAs ThisWorkbook.Path & "\NewDoc.docx"
    If myWord Then wa.Quit Else wd.Close 0
  Else
    MsgBox "Нет связи с открытым документом Word", vbCritical
  End If
End Sub