Excel VBA to Populate Word Header Bookmark

[Dawber]

I am using data in an Excel sheet to populate bookmarks in a Word document template, see code below for details. To this point, the macro operates perfectly but I am now struggling to place data against an additional bookmark located in the header of the Word template and would appreciate some assistance.

Sub Create_Contract_Directories()

ActiveSheet.Cells(ActiveCell.Row, 1).Select
Dim Reference As Variant
Reference = ActiveCell.Value
ActiveCell.Offset(0, 1).Range("A1").Select
Dim Site As Variant
Site = ActiveCell.Value
ActiveCell.Offset(0, 1).Range("A1").Select
Dim Project As Variant
Project = ActiveCell.Value

Dim appWord As Word.Application
Dim aDoc As Word.Document
Set appWord = CreateObject("Word.Application")

Set aDoc = appWord.Documents.Open(Filename:="C:\Template.dot")
aDoc.Application.Visible = True
aDoc.Bookmarks("Reference").Range.Text = Reference
aDoc.Bookmarks("Site").Range.Text = Site
aDoc.Bookmarks("Project").Range.Text = Project
aDoc.SaveAs Filename:="C:\Template1.doc"
aDoc.Close

Set aDoc = Nothing
appWord.Quit
Set appWord = Nothing

End Sub

 

[UnsolvedCoding]

Is the problem with the header itself or the bookmark?

 

[macropod]

Hi Dawber,

Try the following. Note that the reference cells don't get selected/activated. You may need to adjust the references, but you too shouldn't need to select/activate any cells (other than the one that is already selected/activated when the macro starts).

Sub Create_Contract_Directories()
Dim Reference As String, Site As String, Project As String
Dim appWord As Word.Application, aDoc As Word.Document
With ActiveSheet
  Reference = .Cells(ActiveCell.Row, 1).Value
  Site = ActiveCell.Offset(0, 1).Value
  Project = ActiveCell.Offset(0, 2).Value
End With
Set appWord = CreateObject("Word.Application")
Set aDoc = appWord.Documents.Open(Filename:="C:\Template.dot", AddToRecentFiles:=False)
Call UpdateBookmark(aDoc, "Reference", Reference)
Call UpdateBookmark(aDoc, "Site", Site)
Call UpdateBookmark(aDoc, "Project", Project)
aDoc.SaveAs Filename:="C:\Template1.doc", AddToRecentFiles:=False
aDoc.Close
Set aDoc = Nothing
appWord.Quit
Set appWord = Nothing
End Sub

Sub UpdateBookmark(Doc As Word.Document, BmkNm As String, NewTxt As String)
Dim BmkRng As Word.Range
With Doc
  If .Bookmarks.Exists(BmkNm) Then
    Set BmkRng = .Bookmarks(BmkNm).Range
    BmkRng.Text = NewTxt
    .Bookmarks.Add BmkNm, BmkRng
  End If
End With
Set BmkRng = Nothing
End Sub

Cheers
Paul Edstein
[MS MVP - Word]

 

[macropod]

It seems the forum's new code tags are mangling code posts. Trying again with QUOTE tags:

Sub Create_Contract_Directories()
Dim Reference As String, Site As String, Project As String
Dim appWord As Word.Application, aDoc As Word.Document
With ActiveSheet
Reference = .Cells(ActiveCell.Row, 1).Value
Site = ActiveCell.Offset(0, 1).Value
Project = ActiveCell.Offset(0, 2).Value
End With
Set appWord = CreateObject("Word.Application")
Set aDoc = appWord.Documents.Open(Filename:="C:\Template.dot", AddToRecentFiles:=False)
Call UpdateBookmark(aDoc, "Reference", Reference)
Call UpdateBookmark(aDoc, "Site", Site)
Call UpdateBookmark(aDoc, "Project", Project)
aDoc.SaveAs Filename:="C:\Template1.doc", AddToRecentFiles:=False
aDoc.Close
Set aDoc = Nothing
appWord.Quit
Set appWord = Nothing
End Sub

Sub UpdateBookmark(Doc As Word.Document, BmkNm As String, NewTxt As String)
Dim BmkRng As Word.Range
With Doc
If .Bookmarks.Exists(BmkNm) Then
Set BmkRng = .Bookmarks(BmkNm).Range
BmkRng.Text = NewTxt
.Bookmarks.Add BmkNm, BmkRng
End If
End With
Set BmkRng = Nothing
End Sub

Cheers
Paul Edstein
[MS MVP - Word]