Блог

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

 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
  

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

 '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 '" amp; sBookmark amp; "' not found in document '" amp; oDoc.Name amp; "'" amp; _
              vbCrLf amp; "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