I can do a mailmerge from Excel via VBA so this was meant to be easy. I have an Excel sheet with data which I want to transfer to a Word document. But nothing I have tried so far has worked and I have scoured the internet high and low for code. - The code opens the Word document but from then on nothing happens. Error Message says Object doesn't support this property or method. Which I think refers to the With block. I have tried other methods but nothing works!
Any other suggestions would be appreciated. Thanks.
(Other things the macro is meant to do are read list of files in directory and add in, some variable content and then save in specified folder with specified name.)
Code
Public Sub KickoffMinutes()
Dim strSMS As String
Dim strAM As String
Dim strClient As String
Dim strClientRef As String
Dim strMeetingDate As String
Dim strInvitees As String
Dim strQuestionsDue As String
Dim strContentDue As String
Dim strDueDate As String
Dim strSubmission As String
Dim strTenderOffice As String
Dim strColourChange As String
Dim ThisFileName As String
'Errorcatch
On Error GoTo Err_Handler
'Your Sheet names need to be correct in here
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Set sh1 = Sheets("TenderData")
Set sh2 = Sheets("MeetingInfo")
Set sh3 = Sheets("TenderTeam")
strSMS = sh1.[B1]
strAM = sh1.[B2]
strClient = sh1.[B4]
strClientRef = sh1.[B5]
strMeetingDate = Format(sh1.[B16], "dddd, d mmmm YYYY")
strQuestionsDue = Format(sh1.[B21], "dddd, d mmmm YYYY")
strContentDue = Format(sh1.[B23], "dddd, d mmmm YYYY")
strDueDate = Format(sh1.[B24], "dddd, d mmmm YYYY")
strTenderFolder = sh1.[B13].Value
strTenderFolderHL = "<A HREF=""" & sh1.[B13].Value & """>Click here to access folder location.</A>"
strInvitees = sh3.[D69].Value
strSubmission = sh1.[B12].Value
'TenderOffice & Colour Coding Changes
If sh1.[B3] = Christine Then
strColourChange = "Please let Christine know within 5 business days of kickoff meeting."
strTenderOffice = "Christine"
Else
strColourChange = "Please advise Karen ASAP"
strTenderOffice = "Karen"
End If
'AllFiles
Dim MyFile As String
Dim Counter As Long
'Create a dynamic array variable, and then declare its initial size
Dim DirectoryListArray() As String
ReDim DirectoryListArray(1000)
'Loop through all the files in the directory by using Dir$ function
MyFile = Dir$(sh1.[B13].Value & "\Client Docs\1 - Original\")
Do While MyFile <> ""
DirectoryListArray(Counter) = MyFile
MyFile = Dir$
Counter = Counter + 1
Loop
' Setup directories
cDir = ActiveWorkbook.Path + "\" 'Change if required
ThisFileName = ThisWorkbook.Name
Dim objWord As Object
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
objWord.Activate
objWord.Documents.Open "\\nrbusinessdata01\SMS\Groups\Sales\Tenders\Tender Templates\Kick-Off Meeting Minutes - SMSx.docx"
With objWord.ActiveDocument
.Item("phSMS").Range.Text = strSMS
.Item("phAM").Range.Text = strAM
.Item("phClient").Range.Text = strClient
.Item("phClientRef").Range.Text = strClientRef
.Item("phMeetingDate").Range.Text = strMeetingDate
.Item("phInvitees").Range.Text = strInvitees
.Item("phContentDue").Range.Text = strContentDue
.Item("phDueDate").Range.Text = strDueDate
.Item("phQuestionsDue").Range.Text = strQuestionsDue
.Item("phSubmission").Range.Text = strSubmission
.Item("phColourChange").Range.Text = strColourChange
.Item("phTenderOffice").Range.Text = strTenderOffice
.Item("phFiles").Range.Text = DirectoryListArray
End With
' Save new file
'Path and YYMM
Dim MinutePath As String
MinutePath = TenderFolder & "\Meetings\"
Dim NewFileName As String
NewFileName = "Kick-Off Meeting Minutes - SMS" & strSMS & ".docx"
objWord.ActiveDocument.SaveAs MinutePath & NewFileName
objWord.Quit
Set wrdDoc = Nothing
Set objWord = Nothing
Exit Sub
Err_Handler:
MsgBox "Word caused a problem. " & Err.Description, vbCritical, "Error: " _
& Err.Number
If WordWasNotRunning Then
oWord.Quit
End If
0:
Set objWord = Nothing
End Sub