Option Explicit
Public Sub CreateOutlookApptTZ()
   Sheets("Sheet1").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 subFolder As Outlook.MAPIFolder
    Dim arrCal As String
    Dim tzCentral As TimeZone, tzUTC As TimeZone
 
    Dim i As Long
         
    On Error Resume Next
    
 Set olApp = Outlook.Application
 Set tzCentral = olApp.TimeZones.Item("Eastern Standard Time")
 Set tzUTC = olApp.TimeZones.Item("UTC")

    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 = 2
    Do Until Trim(Cells(i, 1).Value) = ""
    
    Set olAppt = CalFolder.Items.Add(olAppointmentItem)
           
    With olAppt
     
    'Define calendar item properties
        .StartTimeZone = tzUTC
        .Start = Cells(i, 6) + Cells(i, 7)      '+ TimeValue("9:00:00")
        .EndTimeZone = tzCentral
        .End = Cells(i, 8) + Cells(i, 9)       '+TimeValue("10:00:00")
        .Subject = Cells(i, 2)
        .Location = Cells(i, 3)
        .Body = Cells(i, 4)
        .BusyStatus = olBusy
        .ReminderMinutesBeforeStart = Cells(i, 10)
        .ReminderSet = True
        .Categories = Cells(i, 5)
        .Save
     
    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