【发布时间】：2017-05-19 06:42:22
【问题描述】：
背景： 我们有一个每周例会，我们都坐下来列出我们的日程安排，然后手动将它们输入到主 Excel 表中。这是不方便、耗时且低效的。我们想自动化这个过程。
我们需要什么： Outlook 日历（共 7 个） -> 主 Excel 表 -> 成员计划 Excel 表
Outlook 需求：
- 我们需要所有 7 个 Outlook 日历进入一个 Excel 床单。我们希望它在每周星期五发生。
- excel表格需要有所有者、类别、 主题、开始日期、结束日期、参加者（这已经在下面的代码中）
- 下面的代码需要编辑到自动和 不是手动的。目前我们必须手动选择日期 代码来自日历。我们希望它是自动化的 流程在每周五晚上进行。
- 此外，我们有一个分类系统来说明如果 文件是否保密。这导致代码出现问题 尝试保存时，因为它无法告诉程序该做什么。 这是一个小问题，我们可能可以解决，但是 如果也能实现自动化就好了。
掌握excel表格需要：
- 需要将 7 个日历导入到这一页中
- 上面提到的变量应该是列
- 下面的代码可以很好地做到这一点，但如前所述，我们需要自动化
会员计划 Excel 表：
-
此 Excel 表有一个成员列表，其中包含日期和日期 月。示例：
-
我们需要根据来自 掌握excel表
一个。示例：如果 Person1 计划在 2017 年 10 月 4 日休假到 2017 年 10 月 10 日，我们需要在对应的方框中填上“V” 该人在 Excel 工作表中的日期。
-
工作表需要满足的标准是：
一个。两张纸上的活动日期匹配
b.日历的所有者匹配人（这将必须被搜索 按关键字... 示例：会员计划 Excel 表上的第一个最后一个 将在 master 上显示为“first.last@email.com\calendar” excel表格。）
c。寻找某些关键字（即“假期”、“人”等……我们 将这些）设置在主工作表主题框列内 确定添加的特定日期和人员是否是假期 天，个人一天，半天假期等。这个命令应该填写 在表中用适当的符号表示什么类型 今天是
d。如果一个事件包含 2 个或多个 Persons，则该列 应该是黄色的，“Major Events/Meetings”被填满 活动名称
- 条件需要返回对应的正确代码 正确的人、日期和事件
- 如果一个事件超过一天，master 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")
这会搜索 Vacation 是否在主题中并返回“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 中的日期匹配时，我才需要“个人”返回 TRUE 匹配（C3，是与宏表上的 D 列匹配的日期）。我只是不知道怎么写。我尝试了一些方法，但一直失败。
我真的需要满足第一个和第二个逻辑然后允许满足第三个逻辑以确定它是否为真。因此，第一个和第二个逻辑就像一个大过滤器，然后第三个（以及之后的其他逻辑）将是构成工作表的最终过滤器。
【问题讨论】：