Question

我接受了以下代码：http://www.vbaexpress.com/forum/showthread.php?25423-Solved-Excel-generate-calendar-appointments-in-Outlook（上一篇文章）。

我不想运行第2行到第10行的代码。我希望它在当前所选单元格的行上运行（即如果我在单元格J：19上，那么我只希望它在行上运行19）。

（该代码根据某些单元格中的数据在Outlook中打开日历约会。）

Option Explicit      

Sub AddToOutlook()       

    Dim OL As Outlook.Application 
    Dim olAppt As Outlook.AppointmentItem 
    Dim NS As Outlook.Namespace 
    Dim colItems As Outlook.Items 
    Dim olApptSearch As Outlook.AppointmentItem 
    Dim r As Long, sSubject As String, sBody As String, sLocation As String 
    Dim dStartTime As Date, dEndTIme As Double, dReminder As Double, dCatagory As Double 
    Dim sSearch As String, bOLOpen As Boolean 

    On Error Resume Next 
    Set OL = GetObject(, "Outlook.Application") 
    bOLOpen = True 
    If OL Is Nothing Then 
        Set OL = CreateObject("Outlook.Application") 
        bOLOpen = False 
    End If 
    Set NS = OL.GetNamespace("MAPI") 
    Set colItems = NS.GetDefaultFolder(olFolderCalendar).Items 

    For r = 2 To 10    

        If Len(Sheet1.Cells(r, 2).Value & Sheet1.Cells(r, 1).Value) = 0 Then GoTo NextRow 
        sSubject = Sheet1.Cells(r, 2).Value 
        sBody = Sheet1.Cells(r, 5).Value 
        dStartTime = Sheet1.Cells(r, 1).Value 
        dEndTIme = Sheet1.Cells(r, 4).Value 
        sLocation = Sheet1.Cells(r, 6).Value 
        dReminder = 120 

        sSearch = "[Subject] = " & sQuote(sSubject) 
        Set olApptSearch = colItems.Find(sSearch) 

        If olApptSearch Is Nothing Then 
            Set olAppt = OL.CreateItem(olAppointmentItem) 
            olAppt.Body = sBody 
            olAppt.Subject = sSubject 
            olAppt.Start = dStartTime 
            olAppt.Duration = dEndTIme 
            olAppt.Location = sLocation 
            olAppt.Catagory = dCatagory 
            olAppt.Close olSave 
        End If 

NextRow: 
    Next r 

    If bOLOpen = False Then OL.Quit 

End Sub


Function sQuote(sTextToQuote) 
    sQuote = Chr(34) & sTextToQuote & Chr(34) 
End Function

Answer 1

For r = 2 To 10

变为

For r = ActiveCell.Row To ActiveCell.Row

获得最快的修复。换句话说，只针对活动行，而不是2到10

正确的方法是用

替换该行

r = ActiveCell.Row

取消代码阻止Next r语句，并删除Next r语句。

更了解VBA的人可以给你一个更可靠的答案。

Answer 2

您只需删除For...Next声明。

正如枪手在他的回答中所述，你还需要使r成为静态值，并且因为你希望这是在你使用r = ActiveCell.Row时选择的任何一个单元格。

有关range.row的更多信息：

返回范围中第一个区域的第一行的编号。只读长。

<强>语法

表达。的行

expression 表示范围对象的变量。

所以这段代码应该适合你：

Option Explicit Sub AddToOutlook() Dim OL As Outlook.Application Dim olAppt As Outlook.AppointmentItem Dim NS As Outlook.Namespace Dim colItems As Outlook.Items Dim olApptSearch As Outlook.AppointmentItem Dim r As Long, sSubject As String, sBody As String, sLocation As String Dim dStartTime As Date, dEndTIme As Double, dReminder As Double, dCatagory As Double Dim sSearch As String, bOLOpen As Boolean On Error Resume Next Set OL = GetObject(, "Outlook.Application") bOLOpen = True If OL Is Nothing Then Set OL = CreateObject("Outlook.Application") bOLOpen = False End If Set NS = OL.GetNamespace("MAPI") Set colItems = NS.GetDefaultFolder(olFolderCalendar).Items r = ActiveCell.row If Len(Sheet1.Cells(r, 2).Value & Sheet1.Cells(r, 1).Value) = 0 Then Exit Sub sSubject = Sheet1.Cells(r, 2).Value sBody = Sheet1.Cells(r, 5).Value dStartTime = Sheet1.Cells(r, 1).Value dEndTIme = Sheet1.Cells(r, 4).Value sLocation = Sheet1.Cells(r, 6).Value dReminder = 120 sSearch = "[Subject] = " & sQuote(sSubject) Set olApptSearch = colItems.Find(sSearch) If olApptSearch Is Nothing Then Set olAppt = OL.CreateItem(olAppointmentItem) olAppt.body = sBody olAppt.Subject = sSubject olAppt.Start = dStartTime olAppt.Duration = dEndTIme olAppt.Location = sLocation olAppt.Catagory = dCatagory olAppt.Close olSave End If If bOLOpen = False Then OL.Quit End Sub Function sQuote(sTextToQuote) sQuote = Chr(34) & sTextToQuote & Chr(34) End Function

如何仅在当前行上运行代码

2 个答案: