Using different Range in the body of email based on row's cell criteria - Appointments

[aravindhan_31]

Cross post : Using different Range in the body of email based on row criteria - Appointments

Hi,
I Have this email macro which works perfectly for blocking appointments based on the data in each row in excel , given the complete code below, I need your help to change this line

.Body = Cells(i, 21)

instead of taking body from one cell, I have 3 tabs stored in the same file called " Face to Face", 'Telephonic" & "Tele Presence" with different content.
all these will be differentiated in the excel file in column Z, so the macro should check the value in column Z if Face to Face then use that content as body and same for other 2.


complete code below

Public Sub Block_Calendar() 
    Sheets("Email").Select 
    On Error GoTo Err_Execute 
     
    Dim olApp As Outlook.Application 
    Dim olAppt As Outlook.AppointmentItem 
    Dim blnCreated As Boolean 
    Dim olNs As Outlook.Namespace 
    Dim CalFolder As Outlook.MAPIFolder 
    Dim rng As Range 
    Set rng = Sheets("Calendar").UsedRange 
     
     
    Dim i As Long 
     
    On Error Resume Next 
    Set olApp = Outlook.Application 
     
    If olApp Is Nothing Then 
        Set olApp = Outlook.Application 
        blnCreated = True 
        Err.Clear 
    Else 
        blnCreated = False 
    End If 
     
    On Error GoTo 0 
     
    Set olNs = olApp.GetNamespace("MAPI") 
    Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar) 
     
    i = 11 
    Do Until Trim(Cells(i, 4).Value) = "" 
         
        Set olAppt = CalFolder.Items.Add(olAppointmentItem) 
        With olAppt 
            .MeetingStatus = olMeeting 
             'Define calendar item properties
            .Subject = Cells(i, 6) 
             
             ' doni use location if using a resource
             ' .Location = Cells(i, 2)
            .Body = Cells(i, 21) 
             ' .Attachments.Add Cells(i, 14).Value
            .Categories = Cells(i, 7) 
            .Start = Cells(i, 13) + Cells(i, 14) '+ TimeValue("9:00:00")
            .End = Cells(i, 13) + Cells(i, 15) '+TimeValue("10:00:00")
            .BusyStatus = olBusy 
             ' .ReminderMinutesBeforeStart = Cells(i, 12)
            .ReminderSet = True 
             ' get the recipients
            Dim RequiredAttendee, OptionalAttendee, ResourceAttendee As Outlook.Recipient 
            Set RequiredAttendee = .Recipients.Add(Cells(i, 13).Value) 
            RequiredAttendee.Type = olRequired 
             ' Set OptionalAttendee = .Recipients.Add(Cells(i, 13).Value)
             '    OptionalAttendee.Type = olOptional
             'Set ResourceAttendee = .Recipients.Add(Cells(i, 14).Value)
             '   ResourceAttendee.Type = olResource
             ' For meetings or Group Calendars
            .Display 
             
        End With 
         
        i = i + 1 
    Loop 
    Set olAppt = Nothing 
    Set olApp = Nothing 
     
    Exit Sub 
     
Err_Execute: 
    MsgBox "An error occurred - Exporting items to Calendar." 
     
End Sub

Regards
Arvind