Vba 将Outlook日历导出到Excel以将该工作表用作填充其他工作表的数据

背景： 我们每周都有一次会议，大家坐在一起，拿出我们的日程安排，并手动将其输入到主excel表格中。这是不方便、耗时且效率低下的。我们希望自动化这个过程

我们需要什么： Outlook日历（共7个）->主Excel工作表->成员计划Excel工作表

Outlook需要：

我们需要将所有7个outlook日历放入一个excel 床单。我们希望它每周在周五发生

excel工作表需要有所有者、类别和， 主题、开始日期、结束日期、与会者（已在下面的代码中）

下面的代码需要编辑到它是自动的并且 不是手工的。目前，我们必须手动选择 代码从日历上的。我们希望它是一个自动化系统 这个过程将在每周五晚上进行

此外，我们有一个分类系统，可以说明 文件是否机密。这导致代码出现问题 尝试保存时，因为它无法告诉程序要做什么。 这是一个我们可以解决的小问题，但是 如果它也能自动化就好了

---

主excel表格需要：

这7个日历需要导入到这张表中

上面提到的变量应该是列

下面的代码很好地实现了这一点，但正如前面提到的，我们需要它实现自动化

---

会员日程Excel表：

此excel工作表包含按日期和日期列出的成员列表 一个月。例如：

我们需要根据以下标准填写此excel表： 主excel表

a。示例：如果人员1计划于2017年4月10日休假至 2017年10月10日，我们需要在相应的方框中填入“V” excel表格中该人员的日期

工作表需要满足的标准包括：

a。两张表上的事件日期匹配

b。日历的所有者与此人匹配（必须对此进行搜索 按关键字…示例：成员明细表Excel表上的最后一个 将显示为“第一个”。last@email.com\“日历”在母版上 excel表格。）

c、 寻找某些关键词（如“假期”、“个人”等），我们 将母版图纸主题框列内的这些设置为 确定添加的特定日期和人员是否为假期 日、个人日、半天假期等。此命令应填写 在工作表中使用适当的符号来指示 今天是

d、 如果一个事件包含两个或更多的人，则该列 应为黄色，并在“重大事件/会议”中填入 活动名称

条件需要返回与对应的正确代码 正确的人、日期和事件

如果一个事件超过一天，主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

我需要“个人”返回一个真正的匹配，只有当它匹配带下划线的COUNTIF中的日期时（C3，是一个与宏工作表上的D列匹配的日期）。我只是不知道如何编写它。我尝试了一些方法，但一直失败

我真的需要满足第一个和第二个逻辑，然后允许满足第三个逻辑，以确定其是否为真。因此，第一个和第二个逻辑就像一个大过滤器，然后第三个（以及后面的其他逻辑）将是构成工作表的最终过滤器。

我找到了它

为了防止任何人出现类似问题，我使用的流程是：

我有一张excel表格，它使用：

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

这将对Outlook中导出的数据进行索引，以便只输入该日历中针对同一个人和日期的所有数据。CalendarExport.xlsx中的C:C列是所需的数据（个人、假期等）

我只是为每个人做了一个单独的公式。（别忘了cntl+shift+enter）

虽然这提供了我需要的数据，但它也提供了更多。例如，如果某人理发，它会在与此人和理发日期对应的单元格中输入“haircut”

为了解决这个问题，我做了另一张纸，从中过滤出来。 第二页使用：

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

这只是在为outlook导出编制索引的单元格中查找关键字，如果为true，则放入相应的代码

这让我有了一张有V、p和Hd的表格，没有其他信息。所以，我有了我所需要的一切

为了自动将数据发送到日历工作表，我只做了一个宏来复制它。我不想在主工作表上有一个公式来连接到这个较小的工作表，因为数据每周五更新一次，所以如果我使用公式来查找单元格所需的文本，前一周的数据将被删除

为了从过滤后的日历表复制数据并将其作为文本（而不是公式）粘贴到主日历表中，我使用了以下方法：

   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

由于我的主日历是如何设置的，我不得不复制并粘贴在四个独立的块中。但是，对我来说没有问题

在主页上，我在上角放了一个按钮，允许该页面运行宏，以便随时更新

我仍然需要在outlook导出的自动化工作，但应该不是很难与一些编码和谷歌

祝你好运！

我想出来了

为了防止任何人出现类似问题，我使用的流程是：<

   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