Question

我试图设置一些VBA代码来创建新的Outlook约会，但前提是单元格中包含“是”一词。我有这种工作方式，但是只要该单元格包含“否”或“ N / A”，它就会停在那里-我希望它只是忽略这些内容。

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

Answer 1

示例示例工作表快照附在下面。

以下示例代码对我有用。

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的评论，在“ Column10”中添加“ Needs Chasing”。修改后的代码如下所示。

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

Answer 2

怎么样？

Sub AppointmentAutomation()

    Dim OutApp As Object
    Set OutApp = CreateObject("Outlook.Application")

    Dim oAppt As AppointmentItem
    Dim oPattern As RecurrencePattern
    Set oAppt = OutApp.CreateItem(olAppointmentItem)
    Set oPattern = oAppt.GetRecurrencePattern
    With oPattern
        .RecurrenceType = olRecursWeekly
        .DayOfWeekMask = olMonday
        .PatternStartDate = Worksheets("Sheet1").Range("A2")
        .PatternEndDate = Worksheets("Sheet1").Range("B2")
        .Duration = 60
        .StartTime = Worksheets("Sheet1").Range("C2")
        .EndTime = Worksheets("Sheet1").Range("D2")
    End With
    oAppt.Subject = Worksheets("Sheet1").Range("E2")
    oAppt.Save
    oAppt.Display

Set OutApp = Nothing

End Sub

如果单元格仅包含某些文本，则尝试将Excel数据作为Outlook约会导入

2 个答案: