将Outlook日历导出到Excel以将该工作表用作数据以填充另一个

Background: 我们有一个每周一次的 Session ，我们都会坐下来制定我们的日程安排并手动将它们输入到主Excel表格中 . 这是不方便的，耗时且低效的 . 我们希望自动化该过程 .

What we need: Outlook日历（共7个） - >主Excel表 - >成员计划Excel表

Outlook needs:

• 我们需要将所有7个outlook日历放入一个excel表中 . 我们希望它在星期五每周发生一次 .

• excel表需要拥有所有者，类别，主题，开始日期，结束日期，与会者的变量（这已在下面的代码中）

• 以下代码需要编辑到自动而非手动的位置 . 目前，我们必须手动选择代码在日历上绘制的日期 . 我们希望它是每周五晚上进行的自动化过程 .

• 此外，我们有一个分类系统，以说明文件是否保密 . 这在尝试保存时导致代码出现问题，因为它无法告诉程序该做什么 . 这是一个我们可以解决的小问题，但也可以将其自动化 .

Master excel sheet needs:

• 需要将7个日历导入此一个工作表

• 上面提到的变量应该是列

• 下面的代码做得很好，但如上所述，我们需要它自动化

Member Schedule Excel Sheet:

• 此Excel表格列出了按日期和月份分列日期的成员 . 例：

• 我们需要根据主Excel工作表中的条件填写此Excel工作表

一个 . 示例：如果Person1的假期安排在2017年4月10日至10月10日，我们需要在Excel工作日内为该人员填写“V”的相应框 .

• 表格需要满足的标准是：

一个 . 两张纸上的事件日期匹配

湾日历的所有者与人匹配（这将必须通过关键字搜索...例如：成员日程表中的第一个最后一个Excel工作表将在主Excel工作表上显示为“first.last@email.com \ calendar” . ）

C . 在主表单主题框列中查找某些关键字（即“休假”，“persoanl”等等...我们将设置这些）以确定特定日期和人员是否已添加为休假日，个人日，半天此命令应该用相应的符号填写表单，以指示它是什么类型的日期

d . 如果某个事件包含2个或更多个人，则该列应为黄色，并且“主要事件/ Session ”将填充事件名称

• 标准需要返回与正确的人，日期和事件对应的正确代码

• 如果一个事件超过一天，主excel将只有开始日期和结束日期，我们将需要在中间的所有日期用正确的符号突出显示 .

到目前为止，我所做的代码是：

=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")

这将搜索假期是否在主题中并返回“V”

正如你所看到的，它很长，只有一件事......

这是将Outlook中的日历带入Excel的代码：它可以工作，但不是自动化的 .

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

如果您有任何其他问题或疑惑，请告诉我，我正在努力解决这个问题 .

到目前为止我有这个：

=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")

我需要“个人”才能返回TRUE匹配，只有它与下划线COUNTIF中的日期匹配（C3，是与宏表上的D列匹配的日期） . 我只是不知道该怎么写 . 我尝试了一些事情并且一直都在失败 .

我真的需要满足第一和第二逻辑然后允许满足第三个逻辑以确定它是否真实 . 因此，第一个和第二个逻辑就像一个大型过滤器，然后第三个（以及之后的其他逻辑）将是制作表单的最终过滤器 .