如何根据 Excel 数据创建日程？

假设您在 Excel 工作表中拥有如截图所示的日程数据表，现在需要将这些数据快速导入到日历中，该如何高效完成这一操作？

使用 VBA 代码将 Excel 数据创建为日程

---

使用 VBA 代码将 Excel 数据创建为日程

若要根据 Excel 数据创建日程，可以应用以下 VBA 代码，请按如下操作：

11. 启动 Outlook，按住 ALT + F11 键，即可打开 Microsoft Visual Basic for Applications 窗口。

22. 单击插入 > 模块，然后将以下代码粘贴到模块窗口中。

VBA 代码：将 Excel 数据导入为日程：

Public Sub CreateOutlookApptz()
    Dim xAppointmentItem As Outlook.AppointmentItem
    Dim xNameSpace As Outlook.NameSpace
    Dim xCalendarFld As Outlook.MAPIFolder, xSubFolder As Outlook.MAPIFolder
    Dim xCalendarStr As String
    Dim I As Long
    Dim xFileDialog As FileDialog
    Dim xFilePath As String
    Dim xExcelApp As Excel.Application
    Dim xWb As Workbook
    Dim xWs As Worksheet
    On Error GoTo Err_Execute
    Set xExcelApp = New Excel.Application
    Set xFileDialog = xExcelApp.FileDialog(msoFileDialogFilePicker)
    With xFileDialog
        .Title = "Select a file"
        .Filters.Add "Microsoft Excel", "*.xlsx"
    End With
    If xFileDialog.Show = 0 Then Exit Sub
    xFilePath = xFileDialog.SelectedItems(1)
    Set xWb = xExcelApp.Workbooks.Open(xFilePath)
    Set xNameSpace = Outlook.Application.Session
    Set xCalendarFld = xNameSpace.GetDefaultFolder(olFolderCalendar)
    I = 2
    Set xWs = xWb.Worksheets.Item(1)
    xCalendarStr = xWb.Name
    If FolderExist(xCalendarFld, xCalendarStr) = False Then
        Set xSubFolder = xCalendarFld.Folders.Add(xCalendarStr, olFolderCalendar)
    Else
        Set xSubFolder = xCalendarFld.Folders(xCalendarStr)
    End If
    Do Until Trim(xWs.Cells(I, 1).Value) = ""
        Set xAppointmentItem = xSubFolder.Items.Add(olAppointmentItem)
        With xAppointmentItem
            .Start = xWs.Cells(I, 5) + xWs.Cells(I, 6)
            .End = xWs.Cells(I, 7) + xWs.Cells(I, 8)
            .Subject = xWs.Cells(I, 1)
            .Location = xWs.Cells(I, 2)
            .Body = xWs.Cells(I, 3)
            .BusyStatus = olBusy
            .ReminderMinutesBeforeStart = xWs.Cells(I, 9)
            .ReminderSet = True
            .Categories = xWs.Cells(I, 4)
            .Save
        End With
        I = I + 1
    Loop
    Set xAppointmentItem = Nothing
    Set olApp = Nothing
    xExcelApp.Quit
    Set xExcelApp = Nothing
    MsgBox "Import successfully!", vbInformation, "Kutools for Outlook"
    Exit Sub
Err_Execute:
    MsgBox "An error occurred - Exporting items to Calendar.", vbInformation, "Kutools for Outlook"
End Sub
Function FolderExist(CalFolder As Folder, FolderName As String) As Boolean
    Dim I As Integer
    Dim xSubFolder As Folder
    For I = 1 To CalFolder.Folders.Count
        Set xSubFolder = CalFolder.Folders.Item(I)
        If xSubFolder.Name = FolderName Then
            FolderExist = True
            Exit Function
        End If
    Next I
End Function

33. 仍在 Microsoft Visual Basic for Applications 窗口，点击工具> 引用，进入 引用-Project 1 对话框，在其中勾选 Microsoft Excel 对象库选项，该选项位于可用引用列表框中，如下截图所示：

44. 然后单击确定按钮，现在，按下 F5 键运行该代码，此时会弹出选择文件窗口，请选择要导入到 Outlook 的 excel 文件，如下截图所示：

5. 点击确定后，即会弹出如下提示框：

6 接着点击确定，Excel 数据已导入到日历中，如下截图所示：