Not able to run code for embedded Word template in Excel for the second time

Question

With the great help of Cindy Meister code for writing into embedded MS Word template to Excel has been achieved. However the problem is that first time you open Excel and run the code everything goes smooth. Once you want to run the code again everything works until closing opened MS Word template. Excel is able to open it again and fill in data from Excel but when it is trying to close it on the second run you get an error:

"Microsoft Word has stopped working". "Windows can try to recover your information." "-> Close the program"

Then you wait some time (like 10 minutes) and try to run the code again and it goes smooth again without any error.

If you open and close Excel then everything works every time.

So it actually runs the code on the second run and saves file but cannot exit Ms Word. I have tried to set everything to =Nothing. The problem must be in some Variable that stays in memory after running the code?

Sorry I may ask question wrong but I hope you can understand from the code what it is doing.

Here is the code:

Sub opentemplateWord1()
    Dim sh As Shape
    Dim objWord As Object, objNewDoc As Object ''Word.Document
    Dim objOLE As OLEObject
    Dim wSystem As Worksheet
    Dim cell As Range
Dim xlRng As Excel.Range
Dim xlSht As Worksheet
Dim wdRng As Object 'Word.Range

    Set wSystem = Worksheets("Templates")
    ''The shape holding the object from 'Create from file'
    ''Object 2 is the name of the shape
    Set sh = wSystem.Shapes("Template1")
    ''The OLE Object contained
    Set objOLE = sh.OLEFormat.Object
    'Instead of activating in-place, open in Word
    objOLE.Verb xlOpen
    Set objWord = objOLE.Object 'The Word document

    Dim objUndo As Object 'Word.UndoRecord
   'Be able to undo all editing performed by the macro in one step
    Set objUndo = objWord.Application.UndoRecord
    objUndo.StartCustomRecord "Edit In Word"

    With objWord
        .Bookmarks.Item("Date").Range.Text = ThisWorkbook.Sheets("Main").Range("K5").Value
        .Bookmarks.Item("DocumentName").Range.Text = ThisWorkbook.Sheets("Main").Range("K6").Value
        .Bookmarks.Item("ProjectNumber").Range.Text = ThisWorkbook.Sheets("Main").Range("K6").Value

With xlSht
  Set xlRng = Sheets("Data").Range("D3", Sheets("Data").Range("D" & Rows.Count).End(xlUp))
End With

Set wdRng = .Range.Characters.Last

Set xlSht = Sheets("Data")
  For Each cell In xlRng
    wdRng.InsertAfter vbCr & cell.Offset(0, -1).Text
     Select Case LCase(cell.Value)
        Case "title"
          wdRng.Paragraphs.Last.Style = .Styles("Heading 1")
        Case "main"
          wdRng.Paragraphs.Last.Style = .Styles("Heading 2")
        Case "normal"
          wdRng.Paragraphs.Last.Style = .Styles("Data")
    End Select
  Next cell

  Set xlSht = Nothing


        objWord.SaveAs2 ActiveWorkbook.Path & "\" & _
        Sheets("Data").Range("C3").Value & ".docx"

        objUndo.EndCustomRecord
        Set objUndo = Nothing
        objWord.Undo
        .Application.Quit False
Set objOLE = Nothing

    End With
    Set objWord = Nothing
End Sub