Мой текущий код удаляет закладки в слове, есть ли способ сохранить закладки?

Question

У меня есть код, который копирует данные из электронной таблицы в определенные закладки на конкретном документе. Когда он запускается, он работает нормально, но закладки удаляются из электронной таблицы. Есть ли способ сохранить закладки в документе

Dim ws As Worksheet

    Set ws = ThisWorkbook.Sheets("Sheet6")

    Set objWord = CreateObject("Word.Application")

    objWord.Visible = True

    objWord.Documents.Open "C:\GR1 CPA Test1.docx" ' change as required

    With objWord.ActiveDocument
        .Bookmarks("CN1").Range.Text = ws.Range("C25").Value
        .Bookmarks("CN2").Range.Text = ws.Range("C25").Value
        .Bookmarks("CNo").Range.Text = ws.Range("C26").Value
        .Bookmarks("CL1").Range.Text = ws.Range("C27").Value
        .Bookmarks("Ex1").Range.Text = ws.Range("C28").Value
        .Bookmarks("Ex2").Range.Text = ws.Range("C28").Value
        .Bookmarks("Su1").Range.Text = ws.Range("C29").Value
        .Bookmarks("Su2").Range.Text = ws.Range("C29").Value
        .Bookmarks("Su3").Range.Text = ws.Range("C29").Value

    .Save
    .Close

    End With

    Set objWord = Nothing


End Sub

Answer 1

Я использовал это в прошлом:

'Replace the text in a bookmark or insert text into an empty (zero-length) bookmark
Sub SetBookmarkText(oDoc As Word.Document, sBookmark As String, sText As String)

    Dim BMRange As Word.Range

    If oDoc.Range.Bookmarks.Exists(sBookmark) Then
      Set BMRange = oDoc.Range.Bookmarks(sBookmark).Range
      BMRange.Text = sText
      oDoc.Range.Bookmarks.Add sBookmark, BMRange
    Else
      MsgBox "Bookmark '" & sBookmark & "' not found in document '" & oDoc.Name & "'" & _
              vbCrLf & "Content not updated"
    End If

End Sub

Использование:

    Dim ws As Worksheet, doc as object

    Set ws = ThisWorkbook.Sheets("Sheet6")

    Set objWord = CreateObject("Word.Application")

    objWord.Visible = True

    Set doc = objWord.Documents.Open("C:\GR1 CPA Test1.docx")

    SetBookmarkText doc, "CN1", ws.Range("C25").Value
    SetBookmarkText doc, "CN2", ws.Range("C25").Value
    'etc etc

    doc.Save
    doc.Close
    Set objWord = Nothing

End Sub