时间戳

首页 > 解决方案 > 如果单元格包含某些文本，则创建 Outlook 约会

excel - 如果单元格包含某些文本，则创建 Outlook 约会

问题描述

如果单元格包含“是”字样，我正在尝试使用 Excel 数据创建新的 Outlook 约会。

Sub AddAppointments()

' Create the Outlook session
Set myOutlook = CreateObject("Outlook.Application")

' Start at row 4    
r = 4

Do Until Trim(Cells(r, 1).Value) = ""

    ' Create the AppointmentItem
    Set myApt = myOutlook.CreateItem(1)

    ' Set the appointment properties
    myApt.Subject = Cells(r, 3).Value
    myApt.Start = Cells(r, 7) + Cells(r, 8).Value

    If Trim(Cells(r, 5).Value) = "" Then
        myApt.BusyStatus = 2
    Else
        myApt.BusyStatus = Cells(r, 5).Value
    End If

    If Cells(r, 10).Value = "Yes" Then
        myApt.ReminderSet = True
    Else
        myApt.ReminderSet = False
    End If

    myApt.Body = "£" & Cells(r, 6).Value
        myApt.Save
        r = r + 1
    Loop
End Sub

如果单元格包含“否”或“N/A”，它将停止。我希望它忽略这些。

标签： excelvbaoutlook

解决方案

示例工作表快照附在下面。 在此处输入图像描述

以下示例代码适用于我。

Option Explicit    
Sub test2()

        Dim OL As Outlook.Application, Appoint As Outlook.AppointmentItem, ES As Worksheet, _
        r As Long, i As Long, WB As ThisWorkbook

        Set WB = ThisWorkbook
        Set ES = WB.Sheets("Sheet1")
        r = ES.Cells(Rows.Count, 1).End(xlUp).Row
        Set OL = New Outlook.Application
    For i = 2 To r
        Set Appoint = OL.CreateItem(olAppointmentItem)
        With Appoint
            .Subject = ES.Cells(i, 1).Value
            .Start = ES.Cells(i, 2).Value
            .End = ES.Cells(i, 3).Value
            .Location = ES.Cells(i, 4).Value
            .AllDayEvent = ES.Cells(i, 5).Value
            .Categories = ES.Cells(i, 6).Value & " Category"
            .BusyStatus = ES.Cells(i, 7).Value
            .ReminderSet = True
            .ReminderMinutesBeforeStart = 60
            .Body = ES.Cells(i, 8).Value
            .Save
        End With
    Next i
     Set OL = Nothing

    End Sub

编辑

根据 OP 的评论，将“Needs Chasing”放入Column10. 修改后的代码如下。

Sub test3()

    Dim OL As Outlook.Application, Appoint As Outlook.AppointmentItem, ES As Worksheet, _
    r As Long, i As Long, WB As ThisWorkbook

    Set WB = ThisWorkbook
    Set ES = WB.Sheets("Sheet1")
    r = ES.Cells(Rows.Count, 1).End(xlUp).Row
    Set OL = New Outlook.Application
For i = 2 To r
    If ES.Cells(i, 10) = "Yes" Then
    Set Appoint = OL.CreateItem(olAppointmentItem)
    With Appoint
        .Subject = ES.Cells(i, 1).Value
        .Start = ES.Cells(i, 2).Value
        .End = ES.Cells(i, 3).Value
        .Location = ES.Cells(i, 4).Value
        .AllDayEvent = ES.Cells(i, 5).Value
        .Categories = ES.Cells(i, 6).Value & " Category"
        .BusyStatus = ES.Cells(i, 7).Value
        .ReminderSet = True
        .ReminderMinutesBeforeStart = 60
        .Body = ES.Cells(i, 8).Value
        .Save
    End With
    End If
Next i
 Set OL = Nothing

End Sub

推荐阅读