CODEWITHSUNDEEP
vbaexcel
Boswell
Boswell

Reputation: 102

How to run code on current row only

I have taken code from: http://www.vbaexpress.com/forum/showthread.php?25423-Solved-Excel-generate-calendar-appointments-in-Outlook (last post).

I do not want to run the code for rows 2 to 10. I want it to run on the row with the currently selected cell (i.e. if I am on cell J:19, then I only want it to run on row 19).

(The code opens a calendar appointment in Outlook based on data in certain cells.)

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

Upvotes: 1

Views: 1144

Answers (2)

K.Dᴀᴠɪs
K.Dᴀᴠɪs

Reputation: 10139

You simply need to remove the For...Next statement.

As gunfulker stated in his answer, you will also need to make r a static value, and because you want this to be whichever cell is selected at the time you would use r = ActiveCell.Row.

Some more info on 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.

So this code should work for you:

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

Upvotes: 2

gunfulker
gunfulker

Reputation: 674

For r = 2 To 10

becomes

For r = ActiveCell.Row To ActiveCell.Row

for the fastest fix. In other words, only do it for the active row, not 2 through 10

The correct way of doing it would be to replace that line with 

r = ActiveCell.Row

unindent the code block up to the Next r statement, and remove the Next r statement.

Someone who knows VBA better can give you a more reliable answer.

Upvotes: 2

Related Questions