Use excel to change a Word file template - excel

Question

I created a code that sopose to take a Word file template and fill it with data from my excel table.
Sub CreateWordDocs()
Dim CustRow, CustCol, LastRow, TemplRow As Long
Dim DocLoc, TagName, TagValue, TemplName, FileName As String
Dim WordDoc, WordApp As Object
With Sheet1
If ActiveCell.Value = Empty Then
MsgBox "pick a different cell"
End If
DocLoc = Sheet2.Range("K2").Value
'Open File
On Error Resume Next 'if Word ia already running
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
Err.Clear
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
End If
LastRow = .Range("B999").End(xlUp).Row
For CustRow = ActiveCell.Row To LastRow
Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False)
For CustCol = 2 To 8
TagName = Cells(3, CustCol)
TagValue = Cells(CustRow, CustCol).Value
With WordDoc.Content.find
.Text = TagName
.Replacement.Text = TagValue
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next CustCol
FileName = ThisWorkbook.Path & "\" & .Range("B" & CustRow).Value & ".docx"
WordDoc.SaveAs FileName
Next CustRow
WordDoc.Display
End With
End Sub
when I run the code it just opens Word without creating any file....

Answer 1

I am assuming here:
If ActiveCell.Value = Empty Then
MsgBox "pick a different cell"
End If
you wanted the code to stop executing if the selected cell in your Excel Worksheet was empty. If so, then you need to put a Exit Sub after MsgBox:
If ActiveCell.Value = Empty Then
MsgBox "pick a different cell"
Exit Sub
End If
I am also assuming that you have at least two Worksheets in your Excel doc because of:
Line 5: With Sheet1
Line 11: DocLoc = Sheet2.Range("K2").Value
It seems that you only use Sheet2 in your code to get the path of your Word Template, and everything else (Cells and Range statements) is meant to be referenced to Sheet1.
Even if the above assumptions are correct, it is not clear if you want to close the re-saved Word documents once they are filled.
If you don't close the individual Word docs once they are filled and saved, you may end up having huge amount of Word documents open depending how many Customers you have in your Excel Worksheet.
Your PC may run out of free memory, slows down very much, or who knows.
Based on the above assumptions, I made some changes in your code to make it run.
Let me know if you wanted it to do something else.
Make sure you have Microsoft Word Object Library enabled in VBA Editor, Tools -> References.
Depending on the version of your Office installed, the module to be enabled might have a different version number.
This is the complete code block after the edits:
Sub CreateWordDocs()
Dim CustRow, CustCol, LastRow, TemplRow As Long
Dim DocLoc, TagName, TagValue, TemplName, FileName As String
Dim WordDoc, WordApp As Object
Dim WBook As Workbook
Set WBook = Application.ActiveWorkbook
Dim Sheet1 As Worksheet
Dim Sheet2 As Worksheet
Set Sheet1 = WBook.Worksheets(1)
Set Sheet2 = WBook.Worksheets(2)
With Sheet1
If ActiveCell.Value = "" Then
MsgBox "pick a different cell"
Exit Sub
End If
DocLoc = Sheet2.Range("K2").Value
On Error Resume Next
'Set WordApp = GetObject("Word.Application")
Set WordApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Err.Clear
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
End If
'LastRow = .Range("B999").End(xlUp).Row
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
For CustRow = ActiveCell.Row To LastRow
Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False)
For CustCol = 2 To 8
TagName = .Cells(3, CustCol).Value
TagValue = .Cells(CustRow, CustCol).Value
With WordDoc.Content.Find
.Text = TagName
.Replacement.Text = TagValue
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next CustCol
FileName = ThisWorkbook.Path & "\" & .Range("B" & CustRow).Value & ".docx"
WordDoc.SaveAs FileName
WordDoc.Close
Next CustRow
'WordDoc.Display
End With
End Sub