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

背景：我们有一个每周一次的会议，我们都坐下来，把我们的时间表，并手动input到一个主Excel表单。 这不方便，耗时且效率低下。 我们想自动化这个过程。

我们需要： Outlook日历（共7个） – >主Excel表格 – >会员日程表Excel表格

outlook需要：

1. 我们需要将所有7个Outlook日历放入一个Excel表格中。 我们希望星期五每星期发生一次。
2. Excel工作表需要拥有所有者，类别，主题，开始date，结束date，与会者的variables（这已在下面的代码中）
3. 下面的代码需要被编辑到自动而不是手动的地方。 目前，我们必须手动select代码在日历上绘制的date。 我们希望它是每个星期五晚上的自动化过程。
4. 此外，我们有一个分类系统来说明文件是否是保密的。 这在试图保存时会导致代码的问题，因为它不能告诉程序该做什么。 这是一个小问题，我们可能可以解决，但也会很好，让它自动化。

---

大师Excel表格需求：

1. 这7个日历需要导入到这张表中
2. 上面提到的variables应该是列
3. 下面的代码做得很好，但是如前所述，我们需要自动化

---

会员计划Excel工作表：

1. 这个Excel工作表中有一个按date和月份分组的成员名单。 例：

   

2. 我们需要根据excel表格的标准来填写这个excel表格

   一个。 例如：如果Person1的假期计划于10/04/2017至10/10/2017，那么我们需要在excel工作表内为那个人填写一个“V”的对应框。

3. 该表需要满足的标准是：

   一个。 活动date匹配在两张纸上

   湾 日历的所有者匹配人员（这将必须通过关键字search…例如：会员日程表中的第一个最后一个Excel工作表将在主Excel工作表上显示为“[e-mail] \ calendar”。）

   C。 在主表单主题框列中查找某些关键字（即“假期”，“个人”等等，我们将设置这些关键字），以确定特定date和人添加的是假期，个人日，半天休假等。这个命令应该用适当的符号填写表格，以表明它是哪一天

   d。 如果一个事件包含两个或两个以上的人员，那么该列应该是黄色的，并在“重大事件/会议”中填写事件的名称

4. 标准需要返回与正确的人，date和事件相对应的正确的代码
5. 如果一个事件超过一天，master excel将只有开始date和结束date，我们需要在中间的所有日子用正确的符号突出显示。

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

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

这将search假期是否在主题，并返回一个“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") 

只有匹配带下划线的COUNTIF中的date（C3，是与macros表中的D列匹配的date），才需要“个人”返回TRUE匹配。 我只是不知道该怎么写。 我已经尝试了一些东西，并保持失败。

我真的需要满足第一个和第二个逻辑，那么允许满足第三个逻辑来确定它的真实与否。 所以，第一个和第二个逻辑就像一个大的filter，然后第三个（以及其他的逻辑）将是最终的filter。

Answer 1

我想到了。

我使用的过程只是为了防止任何人有类似的问题是：

我有一个excel表单使用：

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

这从Outlook导出的数据索引input任何日历具有相同的人和date。 CalendarExport.xlsx中的C：C列是所需的数据（个人，休假等）。

我为每个人做了一个单独的公式。 （不要忘记cntl + shift + enter）

虽然这给了我需要的数据，但也给了更多。 例如，如果有人理发，就把“理发”放在与理发人的date对应的单元格中。

为了弥补这一点，我做了另一张表格，通过这个过滤。 使用的第二张纸：

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

这只是在索引Outlook导出的单元格中查找关键字，并将相应的代码设置为true。

这使我有一个V，P和Hd的表，没有其他信息。 所以，我有我需要的一切。

为了自动化数据到日历表，我只是做了一个macros来复制它。 我不希望在主表上有一个连接到这个小表的公式，因为数据在每个星期五都会更新和刷新，所以如果我使用一个公式来查找需要的文本，那么前一周的数据将被删除细胞。

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

  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 

由于我的主日历设置，我不得不复制和粘贴在四个不同的块。 但是，对我来说没问题。

在主表单上，我在顶部放置了一个button，允许该页面运行macros以便随时更新。

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

祝你好运！