Para ajudar é nessa parte que acontece o problema:
r = 2 ' first row with appointment data in the active worksheet
While Len(Cells(r, 1).Formula) > 0
If Cells(r, 13) = 0 Then
Set olAppItem = olApp.CreateItem(olAppointmentItem) ' creates a new appointment
With olAppItem
.Start = Now
.End = Now
.Subject = "No subject"
.Location = ""
.Body = ""
.ReminderSet = True
.MeetingStatus = olMeeting
On Error Resume Next
.Start = Cells(r, 9).Value & " 08:00:00 AM"
.End = Cells(r, 9).Value & " 5:00:00 PM"
.Subject = Cells(r, 9).Value
.ReminderSet = True
.ReminderMinutesBeforeStart = (60 * 24)
.Importance = 2
.RequiredAttendees = Cells(r, 1).Value
.Categories = "TestAppointment"
'.Save

End With
olAppItem.Display
With olApp
If x = 1 Then
Dim Doc As Word.Document
Dim wdRn As Word.Range
Dim Xl As Excel.Application
Dim Ws As Excel.Worksheet
Dim xlRn As Excel.Range

Set Doc = ActiveInspector.WordEditor
Set wdRn = Doc.Range
Set Xl = GetObject(, "Excel.Application")
Set Ws = Xl.Workbooks.Parent.Worksheets(Cells(r, 1).Offset(0, 5).Value)
Set xlRn = Ws.Range("MailBodyText")

xlRn.Copy
wdRn.Paste
Set wdRn2 = wdRn
End If
If x > 1 Then

wdRn2.Paste

End If
End With
x = x + 1

End If
r = r + 1
Wend