Sub Demo()
Application.ScreenUpdating = True
Dim wdApp As Word.Application, wdDoc As Word.Document, StrDocNm As String
Dim bStrt As Boolean, bFound As Boolean
Dim xlWkSht As Worksheet, i As Long, lCol As Long
'Check whether the document exists
StrDocNm = "C:\Users\" & Environ("Username") & "\Documents\Document Name.doc"
If Dir(StrDocNm) = "" Then
  MsgBox "Cannot find the designated document: " & StrDocNm, vbExclamation
  Exit Sub
End If
' Test whether Word is already running.
On Error Resume Next
bStrt = False ' Flag to record if we start Word, so we can close it later.
Set wdApp = GetObject(, "Word.Application")
'Start Word if it isn't running
If wdApp Is Nothing Then
  Set wdApp = CreateObject("Word.Application")
  If wdApp Is Nothing Then
    MsgBox "Can't start Word.", vbExclamation
    Exit Sub
  End If
  ' Record that we've started Word, so we can terminate it later.
  bStrt = True
End If
On Error GoTo 0
'Check if the workbook is open.
bFound = False
With wdApp
  'Hide our Word session
  If bStrt = True Then .Visible = False
  For Each wdDoc In .Documents
    If wdDoc.FullName = StrDocNm Then ' We already have it open
      bFound = True
      Exit For
    End If
  Next
  ' If not open by the current user.
  If bFound = False Then
    ' Check if another user has it open.
    If IsFileLocked(StrDocNm) = True Then
      ' Report and exit if true
      MsgBox "The Word document is in use." & vbCr & "Please try again later.", vbExclamation, "File in use"
      If bStrt = True Then .Quit
      Exit Sub
    End If
    ' The file is available, so open it.
    Set wdDoc = .Documents.Open(Filename:=StrDocNm, AddToRecentFiles:=False, ReadOnly:=False)
    If wdDoc Is Nothing Then
      MsgBox "Cannot open:" & vbCr & StrDocNm, vbExclamation
      If bStrt = True Then .Quit
      Exit Sub
    End If
  End If
  'Reference our worksheet
  Set xlWkSht = ActiveSheet
  'get the column count
  lCol = xlWkSht.UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Column
  With wdDoc
    'Only now can we can process the document!!!
    'Add a mergefield to the document, corresponding to each 'heading' cell in our worksheet.
    For i = 1 To lCol
      If Trim(xlWkSht.Cells(1, i).Text) <> "" Then
        .Fields.Add Range:=.Characters.Last, Type:=wdFieldEmpty, _
        Text:="MERGEFIELD " & xlWkSht.Cells(1, i).Text, PreserveFormatting:=False
      End If
    Next
    If bFound = False Then .Close SaveChanges:=True
  End With
  If bStrt = True Then .Quit
End With
Set wdDoc = Nothing: Set wdApp = Nothing: Set xlWkSht = Nothing
End Sub
Function IsFileLocked(strFileName As String) As Boolean
  On Error Resume Next
  Open strFileName For Binary Access Read Write Lock Read Write As #1
  Close #1
  IsFileLocked = Err.Number
  Err.Clear
End Function