Export Outlook Calendar to Excel to have that sheet used as data to fill another

Question

Background: We have a weekly meeting that we all sit around and dish out our schedules and manually input them into a master excel sheet. This is inconvenient, time consuming, and inefficient. We would like to automate the process.

What we need: Outlook Calendars (7 in total) -> Master Excel Sheet -> Member Schedule Excel Sheet

Outlook needs:

1. We need all 7 outlook calendars to go into one single excel sheet. We want it to happen on a weekly basis on Fridays.
2. The excel sheet needs to have variables for the owner, category, subject, start date, end date, attendees (this is already in the code below)
3. The code below needs to be edited to where it is automatic and not manual. At the moment we have to manually select the dates that the code draws from on the calendar. We want it to be an automated process to take place every Friday evening.
4. Also, we have a system of classification in place to say if the file is confidential or not. This has caused problems with the code when trying to save since it cannot tell the program what to do. This is a minor problem that we could probably work around, but would be nice to have it automated as well.

---

Master excel sheet needs:

1. The 7 calendars need to be imported into this one sheet
2. The variables mentioned above should be the columns
3. The code below does this well, but as mentioned, we need it to be automated

---

Member Schedule Excel Sheet:

1. This excel sheet has a list of the members with dates by day and month. Example:

   

2. We need this excel sheet to be filled based on criteria from the master excel sheet

   a. Example: if Person1 has a vacation scheduled for 10/04/2017 to 10/10/2017, we need the corresponding boxes filled with a “V” on those dates for that person inside of the excel sheet.

3. The criteria needed to be met for the sheet are:

   a. Date of event matches on both sheets

   b. Owner of Calendar matches Person (this will have to be searched by keyword… example: First Last on the Member Schedule Excel sheet will be displayed as “first.last@email.com\\calendar “ on the master excel sheet.)

   c. Look for certain keywords (ie. “vacation”, “persoanl”, etc… we will set these) inside of the master sheet subject box column to determine if the specific date and person has added is a vacation day, personal day, half day vacation, etc. This command should fill in the sheet with the appropriate symbol to indicate what type of day it is

   d. If an event contains 2 or more of the Persons, then the column should be yellow with “Major Events/Meetings” being filled with the name of the event

4. The criteria need to return the correct code corresponding with the correct person, date and event
5. If an event is more than one day, the master excel will only have the start date and end date, we will need for all days in between to be highlighted with the correct symbol.

So far, the code I have made is:

=IF(AND(ISNUMBER(SEARCH("dakota.mccarty",[Macros.xlsx]Sheet1!$A:$A)),(K$3=[Macros.xlsx]Sheet1!$D:$D),(COUNTIF( [Macros.xlsx]Sheet1!$C:$C, "**vacation**"))), $B$15, "0")

This searches if Vacation is in the subject and returns a “V”

As you can see, its long and does only one thing...

This is the code to bring calendars from Outlook into Excel: It works, but isn't automated.

  Sub ExportAppointmentsToExcel()
    'On the next line, the list of calendars you want to export.  Each entry is the path to a calendar.  Entries are separated by a comma.
    Const CAL_LIST = "user1\Calendar, user2\Calendar, user3\Calendar , etc"
    'On the next line, edit the path to and name of the Excel spreadsheet to export to
    Const EXCEL_FILE = "c:\users\415085\desktop\Macros\Macros.xlsx"
    Const SCRIPT_NAME = "Export Appointments to Excel (Rev 2)"
    Const xlAscending = 1
    Const xlYes = 1
    Dim olkFld As Object, _
        olkLst As Object, _
        olkRes As Object, _
        olkApt As Object, _
        olkRec As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        lngRow As Long, _
        lngCnt As Long, _
        strFil As String, _
        strLst As String, _
        strDat As String, _
        datBeg As Date, _
        datEnd As Date, _
        arrTmp As Variant, _
        arrCal As Variant, _
        varCal As Variant
    strDat = InputBox("Enter the date range of the appointments to export in the form ""mm/dd/yyyy to mm/dd/yyyy""", SCRIPT_NAME, Date & " to " & Date)
    arrTmp = Split(strDat, "to")
    datBeg = IIf(IsDate(arrTmp(0)), arrTmp(0), Date) & " 12:00am"
    datEnd = IIf(IsDate(arrTmp(1)), arrTmp(1), Date) & " 11:59pm"
    Set excApp = CreateObject("Excel.Application")
    Set excWkb = excApp.Workbooks.Add()
    Set excWks = excWkb.Worksheets(1)
    'Write Excel Column Headers
    With excWks
        .Cells(1, 1) = "Calendar"
        .Cells(1, 2) = "Category"
        .Cells(1, 3) = "Subject"
        .Cells(1, 4) = "Starting Date"
        .Cells(1, 5) = "Ending Date”
        .Cells(1, 6) = "Attendees"
    End With
    lngRow = 2
    arrCal = Split(CAL_LIST, ",")
    For Each varCal In arrCal
        Set olkFld = OpenOutlookFolder(CStr(varCal))
        If TypeName(olkFld) <> "Nothing" Then
            If olkFld.DefaultItemType = olAppointmentItem Then
                Set olkLst = olkFld.Items
                olkLst.Sort "[Start]"
                olkLst.IncludeRecurrences = True
                Set olkRes = olkLst.Restrict("[Start] >= '" & Format(datBeg, "ddddd h:nn AMPM") & "' AND [Start] <= '" & Format(datEnd, "ddddd h:nn AMPM") & "'")
                'Write appointments to spreadsheet
                For Each olkApt In olkRes
                    'Only export appointments
                    If olkApt.Class = olAppointment Then
                        strLst = ""
                        For Each olkRec In olkApt.Recipients
                            strLst = strLst & olkRec.Name & ", "
                        Next
                        If strLst <> "" Then strLst = Left(strLst, Len(strLst) - 2)
                        'Add a row for each field in the message you want to export
                        excWks.Cells(lngRow, 1) = olkFld.FolderPath
                        excWks.Cells(lngRow, 2) = olkApt.Categories
                        excWks.Cells(lngRow, 3) = olkApt.Subject
                        excWks.Cells(lngRow, 4) = Format(olkApt.Start, "mm/dd/yyyy")
                        excWks.Cells(lngRow, 5) = Format(olkApt.End, "mm/dd/yyyy")
                        excWks.Cells(lngRow, 6) = strLst
                        lngRow = lngRow + 1
                        lngCnt = lngCnt + 1
                    End If
                Next
            Else
                MsgBox "Operation cancelled.  The selected folder is not a calendar.  You must select a calendar for this macro to work.", vbCritical + vbOKOnly, SCRIPT_NAME
            End If
        Else
            MsgBox "I could not find a folder named " & varCal & ".  Folder skipped.  I will continue processing the remaining folders.", vbExclamation + vbOKOnly, SCRIPT_NAME
        End If
    Next
    excWks.Columns("A:I").AutoFit
    excWks.Range("A1:I" & lngRow - 1).Sort Key1:="Category", Order1:=xlAscending, Header:=xlYes
    excWks.Cells(lngRow, 8) = "=sum(H2:H" & lngRow - 1 & ")"
    excWkb.SaveAs EXCEL_FILE
    excWkb.Close
    MsgBox "Process complete.  I exported a total of " & lngCnt & " appointments were exported.", vbInformation + vbOKOnly, SCRIPT_NAME
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    Set olkApt = Nothing
    Set olkLst = Nothing
    Set olkFld = Nothing
End Sub
Private Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
    Dim arrFolders As Variant, _
        varFolder As Variant, _
        bolBeyondRoot As Boolean
    On Error Resume Next
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        Do While Left(strFolderPath, 1) = "\"
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        Loop
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            Select Case bolBeyondRoot
                Case False
                    Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)
                    bolBeyondRoot = True
                Case True
                    Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
            End Select
            If Err.Number <> 0 Then
                Set OpenOutlookFolder = Nothing
                Exit For
            End If
        Next
    End If
    On Error GoTo 0
End Function

Let me know if you have any other questions or confusion, I am struggling real hard with this one.

So far I have this:

=IF(AND(ISNUMBER(SEARCH("dakota.mccarty",[Macros.xlsx]Sheet1!$A:$A)),(COUNTIF([Macros.xlsx]Sheet1!$D:$D,C3)),(COUNTIF([Macros.xlsx]Sheet1!$C:$C,"Personal"))),$B$15, "0")

I need the “Personal” to return a TRUE match only if it matches the date in the underlined COUNTIF (C3, is a date that is being matched with column D on the Macros sheet). I just don't know how to write that. I have tried a few things and keep failing.

I really need the first and second logics to be met THEN allow for the third logic to be met to determine if its true or not. So, the first and second logics are like a large filter, then the third (and other logics after) will be the final filter of what makes the sheet.

Answer 1

I figured it out.

The process I used just in case anyone had a similar problem is:

I had one excel sheet that used:

=INDEX([CalendarExport.xlsx]Sheet1!$C:$C,MATCH("*first.last*"&C$3,[CalendarExport.xlsx]Sheet1!$A:$A&[nate.xlsx]Sheet1!$D:$D,0))

This indexed the exported data from Outlook to just input whatever that calendar had for the same Person and Date. The C:C column in CalendarExport.xlsx is the data needed (the personal, vacation, etc).

I just made a separate formula for each person. (don't forget cntl+shift+enter)

While this gave the data I needed, it also gave much more. For example, if someone got a haircut it put "haircut" in the cell that corresponded with the person and the date of the haircut.

To remedy this, I made another sheet that filtered through this. This second sheet used:

 =IF(COUNTIF(C5,"**vacation**"),"V",IF(COUNTIF(C5,"**personal**"),"P",IF(COUNTIF(C5,"**half day**"),"Hd","")))

This just looked for keywords in the cells that indexed the outlook export, and put the corresponding codes if true.

This allowed me to have a sheet with V's, P's, and Hd's and no other information. So, I had everything I needed.

In order to automate the data to go to the Calendar sheet, I just did a macros to copy it. I didn't want to have a formula on the main sheet to connect to this smaller sheet because the data is updated and refreshed every friday, so the data from the week before would be deleted if I used a formula to find the text needed for the cell.

To copy the data from the filtered calendar sheet and paste it as text (not as a formula) into the Main Calendar sheet, I used the following:

   Sub UpdateCalendar()
'
'Update Calendar
'
'Jan to March
    Sheets("Calendar(Mechanics)").Activate
    ActiveSheet.Range("C16:BO23").Select
    Selection.Copy
    Sheets("2017").Select
    Range("B7").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

'April to June
    Sheets("Calendar(Mechanics)").Activate
    ActiveSheet.Range("BP16:EB23").Select
    Selection.Copy
    Sheets("2017").Select
    Range("B19").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

'July to September
    Sheets("Calendar(Mechanics)").Activate
    ActiveSheet.Range("EC16:GO23").Select
    Selection.Copy
    Sheets("2017").Select
    Range("B31").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

'October to December
    Sheets("Calendar(Mechanics)").Activate
    ActiveSheet.Range("GP16:JB23").Select
    Selection.Copy
    Sheets("2017").Select
    Range("B43").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False


End Sub

Due to how my master calendar is set up, I had to copy and paste in four separate chunks. But, no problem for me.

On the main sheet I put a button at the top corner to allow for that page to run the macros in order to update whenever.

I am still needing to work on automating the outlook export, but should not be very hard with some coding and google.

Good luck!