如何将Outlook日历导出到Excel每周时间表？

Question

我的老板在Outlook中安排了(不同项目)的会议日历.他希望我从Outlook日历中编写VBA,以便获取数据(项目,日期和时间),并在Excel工作表中输入每天在每个项目上花费的时间.Excel工作表包含以列形式编写的所有项目,以及一周中每天的一列.

代码应该能够在当天插入每个项目上花费的时间,并在Excel工作表中插入项目.

我之前从未使用过Excel.

Answer 1

一个简单的谷歌搜索,一点点重构:

Option Explicit

Sub ListAppointments()
    Dim olApp As Object
    Dim olNS As Object
    Dim olFolder As Object
    Dim olApt As Object
    Dim NextRow As Long
    Dim FromDate As Date
    Dim ToDate As Date

    FromDate = CDate("08/25/2017")
    ToDate = CDate("12/31/2017")

    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err.Number > 0 Then Set olApp = CreateObject("Outlook.Application")
    On Error GoTo 0

    Set olNS = olApp.GetNamespace("MAPI")
    Set olFolder = olNS.GetDefaultFolder(9) 'olFolderCalendar
    NextRow = 2

    With Sheets("Sheet1") 'Change the name of the sheet here
        .Range("A1:D1").Value = Array("Project", "Date", "Time spent", "Location")
        For Each olApt In olFolder.Items
            If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then
                .Cells(NextRow, "A").Value = olApt.Subject
                .Cells(NextRow, "B").Value = CDate(olApt.Start)
                .Cells(NextRow, "C").Value = olApt.End - olApt.Start
                .Cells(NextRow, "C").NumberFormat = "HH:MM:SS"
                .Cells(NextRow, "D").Value = olApt.Location
                .Cells(NextRow, "E").Value = olApt.Categories
                NextRow = NextRow + 1
            Else
            End If
        Next olApt
        .Columns.AutoFit
    End With

    Set olApt = Nothing
    Set olFolder = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Sub