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

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...Next陈述。
正如 gunfulker 在他的回答中所说，您还需要制作 r一个静态值，并且因为您希望它成为您将使用 r = ActiveCell.Row 时选择的任何单元格.
关于 range.row 的更多信息:

Returns the number of the first row of the first area in the range. Read-only Long .

Syntax

expression . Row

expression A variable that represents a Range object.

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

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