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
- We need all 7 outlook calendars to go into one single excel sheet. We want it to happen on a weekly basis on Fridays.
- The excel sheet needs to have variables for the owner, category, subject, start date, end date, attendees (this is already in the code below)
- 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.
- 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:
- The 7 calendars need to be imported into this one sheet
- The variables mentioned above should be the columns
- The code below does this well, but as mentioned, we need it to be automated
Member Schedule Excel Sheet:
This excel sheet has a list of the members with dates by day and month. Example:
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.
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 “[email protected]\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
- The criteria need to return the correct code corresponding with the correct person, date and event
- 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:
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.