VBA - Word - Bookmarks disappearing when I try to write text on them

Question

I am trying to make a macro in Excel, which takes a sample Word file with some bookmarks on it and writes something on the bookmarks. It works for one bookmark, but for the second, third, etc it simply deletes the other entries.

E.g. after the running of my code, I have only written "Info4". I see Info1, Info2 and Info 3 being written and deleted while the macro is run.

Any ideas? Here comes the code:

Option Explicit

Public Sub Main()

    If [set_in_production] Then On Error GoTo Main_Error

    Dim word_obj            As Object
    Dim word_doc            As Object
    Dim obj                 As Object
    Dim rng_range           As Variant
    Dim obj_table           As Object
    Dim origDoc$
    Dim l_row&: l_row = 2

    On Error Resume Next

    Set word_obj = GetObject(, "Word.application.14")
    If Err.Number = 429 Then
        Set word_obj = CreateObject("Word.application.14")
        Err.Number = 0
    End If

    If [set_in_production] Then On Error GoTo Main_Error Else On Error GoTo 0
    origDoc$ = ActiveWorkbook.Path & "\" & CStr(Replace(Time, ":", "_")) & "_" & generate_name & ".docx"
    word_obj.Visible = True
    word_obj.DisplayAlerts = False
    Set word_doc = word_obj.Documents.Open(ActiveWorkbook.Path & "\SAMPLE_2.docx")
    word_obj.activedocument.SaveAs Filename:=origDoc

    'after the saveas -> write

    Dim obj_BMRange     As Object

    Set obj_BMRange = word_obj.activedocument.Bookmarks("Info1").Range
    obj_BMRange.Text = "Info1" & vbCrLf
    Set obj_BMRange = Nothing

    Set obj_BMRange = word_obj.activedocument.Bookmarks("Info2").Range
    obj_BMRange.Text = "Info2" & vbCrLf
    Set obj_BMRange = Nothing

    Set obj_BMRange = word_obj.activedocument.Bookmarks("Info3").Range
    obj_BMRange.Text = "Info3" & vbCrLf
    Set obj_BMRange = Nothing

    Set obj_BMRange = word_obj.activedocument.Bookmarks("Info4").Range
    obj_BMRange.Text = "Info4" & vbCrLf
    Set obj_BMRange = Nothing
    word_obj.DisplayAlerts = False

    Set word_obj = Nothing
    Set word_doc = Nothing
    Set rng_range = Nothing
    Set obj = Nothing
    Set obj_table = Nothing

    On Error GoTo 0
    Exit Sub

Main_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Main of Sub mod_main"

End Sub

I have tried to rewrite the bookmarks, once they are deleted, but the success was no different. Thus, waiting for ideas! :D

Answer 1

The following approach works for me. (Note that I had to remove the lines of code specific to your workbook and files since I don't have access to any of that. But it doesn't (shouldn't) change anything relevant to the problem you present.)

Something that makes no sense in the code you posted is declaring a word_doc variable, then not using it, instead relying on ActiveDocument. I substituted word_doc as appropriate.

I also inserted On Error GoTo 0 to re-instate normal error handling. When you use On Error Resume Next normal error handling is deactivated, which you need for your approach with GetObject. But once the Word application is accessed it needs to be turned back on. Using it at the end of the routine makes no sense.

As mentioned by others, Word removes a bookmark when content is written to it if the bookmark already has content (you see [square brackets]). To get around this, the bookmark needs to be recreated around the content assigned to the Range. Since this involves a couple of steps I wrote a separate function for writing to the bookmark - WriteToBookmarkRetainBookmark.

When I test this from Excel the information is written to each bookmark and the bookmarks exist at the end.

Option Explicit

Public Sub Main()

    Dim word_obj            As Object
    Dim word_doc            As Object
    Dim obj                 As Object
    Dim rng_range           As Variant
    Dim obj_table           As Object
    Dim origDoc$
    Dim l_row&: l_row = 2

    On Error Resume Next

    Set word_obj = GetObject(, "Word.application.14")
    If Err.Number = 429 Then
        Set word_obj = CreateObject("Word.application.14")
        Err.Number = 0
    End If
    On Error GoTo 0

    word_obj.Visible = True
    word_obj.DisplayAlerts = False
    Set word_doc = word_obj.ActiveDocument
'    word_obj.ActiveDocument.SaveAs Filename:=origDoc

    'after the saveas -> write

    Dim obj_BMRange     As Object

    Set obj_BMRange = word_doc.Bookmarks("Info1").Range
    WriteToBookmarkRetainBookmark obj_BMRange, "Info1" & vbCrLf
    Set obj_BMRange = Nothing

    Set obj_BMRange = word_doc.Bookmarks("Info2").Range
    WriteToBookmarkRetainBookmark obj_BMRange, "Info2" & vbCrLf
    Set obj_BMRange = Nothing

    Set obj_BMRange = word_doc.Bookmarks("Info3").Range
    WriteToBookmarkRetainBookmark obj_BMRange, "Info3" & vbCrLf
    Set obj_BMRange = Nothing

    word_obj.DisplayAlerts = False

    Set word_obj = Nothing
    Set word_doc = Nothing
    Set rng_range = Nothing
    Set obj = Nothing
    Set obj_table = Nothing

    Exit Sub

Main_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Main of Sub mod_main"

End Sub

Function WriteToBookmarkRetainBookmark(rng As Object, content As String)
    Dim sBkmName As String

    sBkmName = rng.Bookmarks(1).Name
    rng.Text = content
    rng.Document.Bookmarks.Add sBkmName, rng
End Function

Answer 2

Just some workaround I found - using replace in Word - the code is a little "ugly", not dry, but it works:

With word_obj.ActiveDocument.Content.Find
  .Text = "Info001"
  .Replacement.Text = "VITYA1"
  .Execute Replace:=wdReplaceAll

  .Text = "Info002"
  .Replacement.Text = "VITYA2"
  .Execute Replace:=wdReplaceAll

  .Text = "Info003"
  .Replacement.Text = "VITYA3"
  .Execute Replace:=wdReplaceAll

  .Text = "Info004"
  .Replacement.Text = "VITYA4"
  .Execute Replace:=wdReplaceAll

End With

With word_obj.ActiveDocument.Shapes(1).TextFrame.TextRange.Find
    .Text = "Info005"
    .Replacement.Text = "VITYATA5"
    .Execute Replace:=wdReplaceAll

    .Text = "Info006"
    .Replacement.Text = "VITYATA6"
    .Execute Replace:=wdReplaceAll

    .Text = "Info007"
    .Replacement.Text = "VITYATA7"
    .Execute Replace:=wdReplaceAll

    .Text = "Info008"
    .Replacement.Text = "VITYATA8"
    .Execute Replace:=wdReplaceAll

End With

Still, if someone has an idea about how to solve the original issue, I would like to see it :)