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