Copying a rich text table from an Outlook email to Excel using VBA?

EDIT: Added improvements suggested by @PatrickK and added image of spreadsheet.

I eventually figured it out. I was looking at the issue all wrong, I didn't realize I could copy the entire body of the email to the clipboard and then paste it in the Excel spreadsheet without the formatting getting all wonky. This is what I came up with, which appears to work well:

'____________________________________________________________
'
' Author: Joshua Bryant
'
' Version 1.1
'
' Date: 8/16/2016
'
' This routine will search for the system notifier email
' which holds the leave data. Once found, it will call the
' Copy_Paste_Data sub routine which will take the data from
' the selected email and copy it to the clipboard. Once
' copied the subroutine will then paste it into the Excel
' Leave Notifier Table Workbook. It then calls the Add_Time
' subroutine to adjust the start and end time columns of the
' worksheet to allow for a more readable calendar.
' This routine temporarily disables Excel notifications
' Public, passes olItem to Copy_Paste_Data, returns nothing.
'
' Version 1.1: Added exit for loop if statement, to exit 
' loop once email has been found (If Found Then Exit For).
' __________________________________________________________
'

Public Sub Get_Data()
' Declare Variables
  Dim myOlApp As New Outlook.Application
  Dim myNameSpace As Outlook.Namespace
  Dim myInbox As Outlook.MAPIFolder
  Dim myitems As Outlook.Items
  Dim myitem As Object
  Dim Found As Boolean
  Dim olItem As MailItem
  Dim objInsp As Outlook.Inspector
  Dim myDate As Variant
  Dim DateStr As String
  Dim oOutlook As Object

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Un-comment the following section to have program check and
' make sure Outlook is open before proceeding. This is not
' necessary for this program to operate effectively:
'
'    On Error Resume Next
'    Set oOutlook = GetObject(, "Outlook.Application")
'    On Error GoTo 0
'
'    If oOutlook Is Nothing Then
'        MsgBox "Outlook Mail is not open. Please open Outlook Mail and try again."
'        Exit Sub
'    End If
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    ' On error (wrong data type found) it will skip the item and
    ' continue to look for the email.
    On Error Resume Next
    ' Initialize objInsp variable as an inspector item which can be
    ' used to search for, and point, to items in the outlook folder
    Set objInsp = Outlook.Application.ActiveInspector

    ' Create a string item which holds todays date in a specifically formatted manner.
    DateStr = CStr(DatePart("m", Date)) & "/" & CStr(DatePart("d", Date)) & "/" & CStr(DatePart("yyyy", Date))

    ' Initialize variables and select default message folder for search.
    Set myNameSpace = myOlApp.GetNamespace("MAPI")
    Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
    Set myitems = myInbox.Items

    ' Set intitial state of Found variable to False
    Found = False

    ' For loop to search through all items in the selected mail folder.
    For Each myitem In myitems
        ' If the item belongs to outlook mail class continue.
        ' Else continue looking until no items are present.
        If myitem.Class = olMail Then
            ' Once mail item is found compare it's subject to this string.
            ' If sting matchs hold selected item and set Found variable to true.
            ' Else continue looking until no items are present.
            If InStr(1, myitem.Subject, DateStr & " Upcoming Leave Notifier") > 0 Then
                ' Set the held item equal to MailItem type variable to hold it for later use.
                ' Takes object being pointed to and saves it for later use.
                Set olItem = myitem
                ' Set true "flag" (make Found variable True)
                Found = True
                If Found Then Exit For
            End If
        End If
    Next myitem

    ' Once all items have been searched check if Found "flag" is true
    ' If true notify end user and procede to copying and pasting data into worksheept.
    ' If False go to Else.
    If Found = True Then

        MsgBox "Data Found."
        ' If found pass item to Copy_Paste_Data and call sub rountine.
        Copy_Paste_Data olItem

    ' Else query end user for date when email was recieved.
    Else:
' Set point to return to if item was still not found at user provided date.
Not_Found:
        ' Prompt user for date when email was recieved from the system.
        myDate = InputBox("Email with todays date not found." & Chr(13) & Chr(13) & "Please enter the date that the email was recieved in the field below. The date should be written in the mm/dd/yyyy format." & Chr(13) & Chr(13) & "Note: Do not include leading zeros. Ex. 01/02/2015 should be 1/2/2015" & Chr(13))
        ' If the user does not enter a value or presses Cancle then exit routine.
        If myDate = "" Then Exit Sub

        ' Repeat search for email with new date value.
        For Each myitem In myitems
            If myitem.Class = olMail Then
                If InStr(1, myitem.Subject, myDate & " Upcoming Leave Notifier") > 0 Then
                    Set olItem = myitem
                    Found = True
                    If Found Then Exit For
                End If
            End If
        Next myitem

        ' Query again to see if email was found
        If Found = True Then
            ' If found pass item to Copy_Paste_Data and call sub rountine.
            Copy_Paste_Data olItem
        ' Else, repeat prompt to end user.
        Else:
            GoTo Not_Found
        End If
    End If

    ' Once information has been added run add time to index results with start and end times.
     Call Add_Time

End Sub

'____________________________________________________________
'
' Author: Joshua Bryant
'
' Version 1.0
'
' Date: 8/15/2016
'
' This subroutine takes object passed from Get_Data and
' copies the data from the body of the email. It then pastes
' that data into the active Excel sheet.
' This subroutine temporarily disables Excel Display Alerts
' Private, returns nothing.
'____________________________________________________________
'

Private Sub Copy_Paste_Data(olItem)
  ' Delcare / Initialize variable
  Dim DataObj As MSForms.DataObject
  Set DataObj = New MSForms.DataObject
    ' Copy HTML body of email to data object
    DataObj.SetText olItem.HTMLBody
    ' Copy data object to clipboard
    DataObj.PutInClipboard
    ' Disable display alerts (e.g. size doesn't match warning)
    Application.DisplayAlerts = False
    ' Paste the contents of the clipboard to the worksheet (dimensions dont have to match exactly)
    ActiveSheet.Paste Destination:=Worksheets("Leave Table").Range("A3:G300")
    ' Notify end user that data transfer was successful.
    MsgBox "Your data has been transfered successfully."
    ' Re-enable Excel alerts
    Application.DisplayAlerts = True

End Sub


'____________________________________________________________
'
' Author: Joshua Bryant
'
' Version 1.0
'
' Date: 8/15/2016
'
' This subroutine examines the items in the table and looks
' for days where multiple employees have requested time off
' On those days it will increment each employees scheduled
' start and end time by 30 minutes to provide a cleaner
' appointment view on the calendar. This allows the names to
' appear as though they are listed on the days of the week
' they are added to. For each new date, the routine will
' begin the appointment start times at 8:00 AM and add 30
' minuted for every subsequent employee.
' Private, returns nothing.
'____________________________________________________________
'

Private Sub Add_Time()
  ' Initialize variables
  Dim time As Date
  Dim HoldDate As Date
  Dim PrevRowDate As Date
  Dim LastDate As Date
  Dim LastName As String
  Dim NextRowDate As Date

  ' Set Work sheet to be edited
  Dim wsSrc As Worksheet
  Set wsSrc = ActiveWorkbook.Sheets("Leave Table")

    ' Set initial values
    HoldDate = DateValue(wsSrc.Cells(4, 3))
    PrevRowDate = DateValue(wsSrc.Cells(4, 3))
    time = TimeValue("08:00:00")
    ' Set values for first row (after header) of the table (row 3)
    wsSrc.Cells(4, 8).Value = TimeValue("08:00:00")
    wsSrc.Cells(4, 9).Value = TimeValue("08:30:00")
    r = 4

    ' Loop to find the end of the list
    Do Until Trim(wsSrc.Cells(r, 1).Value) = ""
        r = r + 1
    Loop

    ' Set the second to last item as the ending point.
    ' We do not want to use the last row because it would throw a data type error when the end is reached.
    r = r - 1
    LastName = wsSrc.Cells(r, 1).Value
    LastDate = DateValue(wsSrc.Cells(r, 3))

    ' Begin at row 4 (Rows 1 & 2 are headers. Beginning at row 3 would include invalid data type from row 2)
    r = 5

    ' Repeat this loop until the second to last row is reached.
        Do Until wsSrc.Cells(r, 1).Value = wsSrc.Cells(r, 1).Value And DateValue(wsSrc.Cells(r, 3)) = LastDate
        ' Hold the date in the current row
            HoldDate = DateValue(wsSrc.Cells(r, 3))
            ' Set the next date equal to the date being held.
            ' This allows for the next loops conditions to be met for entry into the do/while loop.
            NextRowDate = DateValue(wsSrc.Cells(r, 3))
            ' Get the date from the previous row and hold it for comparison to the held date.
            ' This is done to endure the add time loop is not entered prematurely.
            r = r - 1
            PrevRowDate = DateValue(wsSrc.Cells(r, 3))
            r = r + 1

            ' Add time loop to increment time in calendar by 30 minutes
            ' while HoldDate does not equal PrevRowDate or NextRowDate.
            ' Note: Previous row date holds the same value it recieved from outside of the loop.
            ' Thus, the condition relies entirely on the NextRowDate.
            Do Until HoldDate <> PrevRowDate Or HoldDate <> NextRowDate
                ' Get the date of the next row.
                r = r + 1
                NextRowDate = DateValue(wsSrc.Cells(r, 3))
                r = r - 1
                ' Plase the current time value + 30 min into the Start time column of this row
                wsSrc.Cells(r, 8).Value = CDate(time) + 1 / 48
                ' Add 30 min to the time value
                time = CDate(time) + 1 / 48
                ' Plase the current time value + 30 min into the End time column of this row
                wsSrc.Cells(r, 9).Value = CDate(time) + 1 / 48
                ' Increment row
                r = r + 1
            Loop
            ' Reset time to 8:00 AM
            time = TimeValue("08:00:00")
            ' Place 8:00 Am in the Start time column of this row
            wsSrc.Cells(r, 8).Value = CDate(time)
            ' Place 8:30 Am in the End time column of this row
            wsSrc.Cells(r, 9).Value = CDate(time) + 1 / 48
            ' Increment row
            r = r + 1
        Loop

     ' Add time values for the last date in the table.
     ' Begin at 7:30 AM for simplicity
    time = TimeValue("07:30:00")
     ' Repeat loop to add start and end times for each person on the last day of the
     ' table, adding 30 minutes each time.
    Do Until Trim(wsSrc.Cells(r, 1).Value) = ""
         wsSrc.Cells(r, 8).Value = CDate(time) + 1 / 48
         time = CDate(time) + 1 / 48
         wsSrc.Cells(r, 9).Value = CDate(time) + 1 / 48
         r = r + 1
    Loop

End Sub

The spreadsheet goes out and finds the notification email with today's date and then copies and pastes it into the spreadsheet where it can be edited and later uploaded directly to the global calendar using the following program:

'____________________________________________________________
'
' Author: Joshua Bryant
'
' Version 1.0
'
' Date: 8/16/2016
'
' This is the main program which will call the other subs.
' The Create_Outlook sub calls Clean_Leave_Calendar sub to
' delete all emails from the leave calendar before attempting
' to add new items to the calendar. Once the calendar has
' been cleaned and the times have been added, the program
' creates new appointments items in the predetermined outlook
' folder "oFolder". Once the appointment items have been
' created the program notifies the end user that the process
' ran successfully and runs Close_Workbook subroutine to
' close workbook without saving.
'____________________________________________________________
'

Public Sub Populate_Calendar()
  ' Initialize variables
  Dim oApp As Object
  Dim oNameSpace As Namespace
  Dim oFolder As Object
  Dim wsSrc As Worksheet
  Set wsSrc = Sheets("Leave Table")

  ' Call subroutines
  Call Clean_Leave_Calendar

    ' Start looping at row 3 (first two rows are for readability)
    r = 4
    ' Do/while set condition
    Do Until Trim(wsSrc.Cells(r, 1).Value) = ""

    ' Create the Outlook session
    Set oApp = New Outlook.Application
    ' Set the namespace
    Set oNameSpace = oApp.GetNamespace("MAPI")
    ' Set the folder the appointment will be created in.
    Set oFolder = oNameSpace.GetFolderFromID("000000007CF129E6C6BAA74F9B2AB399FABB280E01006EC36FFC70429B4EAE1875321A4609670078C4FA00320000").Items.Add(olAppointmentItem)

    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Use the following code in Outlook to find the Folder ID #:
    ' Note: WITH THE CALENDAR YOU WANT TO CREATE APPOINTMENTS IN
    ' SELECTED, press F11 to bring up Outlook macros and run the
    ' code under "ThisOutlookSession"
    '
    ' Private Sub GetOutlookFolderID()
    '     'Determines the Folder ID of Folder
    '    Dim olfolder As Outlook.MAPIFolder
    '    Dim olapp As Outlook.Application
    '    Set olapp = CreateObject("Outlook.Application")
    '    Set olfolder = olapp.GetNamespace("MAPI").PickFolder
    '    olfolder.Display
    '    MsgBox (olfolder.EntryID)
    '    Set olfolder = Nothing
    '    Set olapp = Nothing
    ' End Sub
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    ' Set with block for the appointment configuration loop
   With oFolder
       ' Set Subject line of event
        .Subject = wsSrc.Cells(r, 1).Value & " " & wsSrc.Cells(r, 2).Value
       ' Set start time
        .Start = DateValue(wsSrc.Cells(r, 3)) + wsSrc.Cells(r, 8).Value
       ' Set end time
        .End = DateValue(wsSrc.Cells(r, 3)) + wsSrc.Cells(r, 9).Value
       ' Turn reminders off
        .ReminderSet = False
       ' Set busy status to free
        .BusyStatus = 0
       ' Have the body of the event read as the decription from the leave form in Viewpoint
        .Body = wsSrc.Cells(r, 4).Value
       ' Save event in owners calendar
        .Save
       ' End with block
        End With
       ' Move to next row
        r = r + 1
       ' Repeat do/while loop until condition is no longer valid
    Loop

  ' Clean house
  Set oApp = Nothing
  Set oNameSpace = Nothing
  Set oFolder = Nothing
  Set wsSrc = Nothing

  MsgBox "Data was successfully added to the Outlook Leave Calendar." & Chr(13) & Chr(13) & "Excel workbook will now close."

  Call CloseWorkbook

End Sub

'____________________________________________________________
'
' Author: Joshua Bryant
'
' Version 1.0
'
' Date: 8/15/2016
'
' This sub will close the current workbook without saving.
' Before closing it will check to make sure there are no
' other workbooks are open and if there are none, it will
' close the Excel application as well. This sub will also
' temporarily disable displayed "Would you like to save your
' workbook" notification.
' Private, returns nothing.
'____________________________________________________________
'

Private Sub CloseWorkbook()
Application.DisplayAlerts = False
If Workbooks.Count < 2 Then
Application.Quit
Else
ThisWorkbook.Close
End If
End Sub

'____________________________________________________________
'
' Author: Joshua Bryant
'
' Version 1.0
'
' Date: 8/15/2016
'
' This sub will call the Clean_Leave_Calendar subroutine
' 5 times. The Clean_Leave_Calendar subroutine will look for
' appointment items in the predefined outlook folder. Once
' an appointment item is identified the program will
' perminately delete the item to avoid scheduling conflicts
' with new items to be added. The deletion loop runs 10
' times to ensure all items are successfully removed.
' Public, returns nothing
'____________________________________________________________
'

Public Sub Power_Wash()
Dim i As Integer
i = 0
Do Until i = 5
Call Clean_Leave_Calendar
i = i + 1
Loop
End Sub

'____________________________________________________________
'
' Author: Joshua Bryant
'
' Version 1.0
'
' Date: 8/15/2016
'
' This sub will look for appointment items in the predefined
' outlook folder. Once an appointment item is identified the
' program will perminately delete the item to avoid schedule
' conflicts with new items to be added. The deletion loop
' runs 10 times to ensure all items are successfully removed
' Private, returns nothing
'____________________________________________________________
'

Private Sub Clean_Leave_Calendar()
  ' Initialize variables
  Dim oApp As Outlook.Application
  Dim oNameSpace As Outlook.Namespace
  Dim oApptItem As Outlook.AppointmentItem
  Dim oFolder As Outlook.MAPIFolder
  Dim oMeetingoApptItem As Outlook.MeetingItem
  Dim oObject As Object
  Dim i As Integer

  ' Set error states
  On Error Resume Next
  ' Check if Outlook is running
  Set oApp = GetObject("Outlook.Application")
  If Err <> 0 Then
    'If Outlook is not running, start it.
    Set oApp = CreateObject("Outlook.Application")
  End If

  ' Set the folder the appointments can be found in. See main function "Create Outlook" for more details.
  Set oApp = New Outlook.Application
  Set oNameSpace = oApp.GetNamespace("MAPI")
  Set oFolder = oNameSpace.GetFolderFromID("000000007CF129E6C6BAA74F9B2AB399FABB280E01006EC36FFC70429B4EAE1875321A4609670078C4FA00320000")

  ' Set initial value of i to 0
  i = 0
  ' Repeat deleting function 10 times to make sure all apointments have been cleared from the folder.
  Do Until i = 10
    CheckAppointment = False
    ' For each of the "objects" appointments and other in the folder specified above repeat the loop.
    ' Beacause not all of the objects are appointments it sometimes ends to early,
    ' which is why it runs 10 times. (Easier than coding a more stringent code, and really not the
    ' resource demanding).
    For Each oObject In oFolder.Items
        ' Compare each object to appoint class and delete objects where match is found.
        If oObject.Class = olAppointment Then
            Set oApptItem = oObject
            oApptItem.Delete
        End If
    ' Repeat for each object / item.
    Next oObject
  ' Rinse and repeat.
  i = i + 1
  Loop

  ' Clear variables
  Set oApp = Nothing
  Set oNameSpace = Nothing
  Set oApptItem = Nothing
  Set oFolder = Nothing
  Set oObject = Nothing

End Sub

A subroutine clears the shared calendar. Then the main routine uploads the new dates. Lastly, a subroutine then closes the workbook.

If anyone has any suggestions for cleaning this up, please let me know.

Thanks!

Also, here is an image of the Excel sheet I am using.