Option Explicit
Sub PopulateWordFromExcel()
Dim strWordDocPath As String, strWordDocName As String, strWordDocDir As String, strBkMark As String
Dim objWordApp As Object, objWordDoc As Object, objWordBkm As Object, objWordBkmRange As Object
Dim rngCell As Range
'Check if Word is already opened
On Error Resume Next
Set objWordApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
'If it isn't, open a new instance of it
Set objWordApp = CreateObject("Word.Application")
End If
On Error GoTo 0
'Assums full path (directory + filename) of the Word document is in a named range called 'WordPath'. Change to suit.
On Error Resume Next
strWordDocPath = ThisWorkbook.Names(CStr("WordPath")).RefersToRange.Value
If Len(strWordDocPath) = 0 Then
strWordDocPath = Range(CStr("WordPath")).Value
End If
On Error GoTo 0
strWordDocName = Replace(strWordDocPath, Left(strWordDocPath, InStrRev(strWordDocPath, Application.PathSeparator)), "")
strWordDocDir = Left(strWordDocPath, InStrRev(strWordDocPath, Application.PathSeparator))
Select Case FileStatus(strWordDocPath)
Case Is = 53 'Invalid filename
MsgBox "The entered file name..." & vbNewLine & """" & strWordDocName & """" & vbNewLine & "...is invalid." & vbNewLine & "Please check and try again.", vbExclamation, "Populate Word from Excel"
Set objWordApp = Nothing 'Release object from memory
Exit Sub
Case Is = 70 'File is open
MsgBox "The document..." & vbNewLine & """" & strWordDocName & """" & vbNewLine & "...is currently open." & vbNewLine & "Please close it and try again.", vbExclamation, "Populate Word from Excel"
Set objWordApp = Nothing 'Release object from memory
Exit Sub
Case Is = 76 'Invalid path
MsgBox "The entered directory path..." & vbNewLine & """" & strWordDocDir & """" & vbNewLine & "...is invalid." & vbNewLine & "Please check and try again.", vbExclamation, "Populate Word from Excel"
Set objWordApp = Nothing 'Release object from memory
Exit Sub
End Select
Application.ScreenUpdating = False
'Ensure the Word instance the document is in visible
objWordApp.Visible = True
strBkMark = "ClientName" 'Word document bookmark name. Change to suit.
For Each rngCell In ThisWorkbook.Names("Names").RefersToRange
Set objWordDoc = objWordApp.Documents.Open(strWordDocPath)
Set objWordBkm = objWordDoc.Bookmarks(strBkMark)
objWordApp.Selection.GoTo What:=-1, Name:=objWordBkm.Name '-1 = wdGoToBookmark
Set objWordBkmRange = objWordBkm.Range
objWordBkmRange.Text = Replace(objWordBkmRange.Text, objWordBkmRange.Text, rngCell.Text)
With objWordDoc
.Bookmarks.Add strBkMark, objWordBkmRange
.Close -1 '-1 = wdSaveChanges (no prompt)
End With
'I could not get SaveAs2 in Word not to display the File Save dialog so I coded the following as an alternative
FileCopy strWordDocDir & strWordDocName, strWordDocDir & rngCell.Text & ".docx"
Set objWordDoc = Nothing
Next rngCell
Set objWordApp = Nothing 'Release object from memory
Application.ScreenUpdating = True
MsgBox "Excel data has been copied across to Word.", vbInformation, "Populate Word from Excel"
End Sub
'http://www.vbaexpress.com/kb/getarticle.php?kb_id=468
Function FileStatus(strFileName As String) As Long
Dim lngFileNum As Long
Dim lngErr As Long
On Error Resume Next
lngFileNum = FreeFile()
Open strFileName For Input Lock Read As #lngFileNum
Close lngFileNum
FileStatus = Err
On Error GoTo 0
End Function
)
