Excel to outlook appointment date based on row selection question

[lilsnoop]

Hello,

I was curious if the following code could be amended somehow so that the date range would be based on the row selected and then pull the date from column "D" of that same row selection? Ideally the user would select the row/date they want by selecting the row in column H. So if they selected cell H30 the appointment reminder would then populate in Outlook for the date in Column D, row 30, etc. Currently this code pulls in the date in cell S1 only. Any assistance would be greatly appreciated!

Sub CreateAppt()
On Error GoTo erHandle
Dim olApp As Object
Dim olItem As Object
Dim dt As Date
Dim dk As String
Dim Msg As String, Ans As Variant
Sheets("Log").Unprotect Password:="test"
 Msg = "Do you want to set an appointment reminder?"
 Ans = MsgBox(Msg, vbYesNo)
 Select Case Ans
 Case vbYes
dt = Range("S1").Value
dk = Range("S2").Value
Set olApp = CreateObject("Outlook.Application")
Set olItem = olApp.CreateItem(1)



With olItem
    .Subject = Range("S3") 'Change to cell that has value for subject
    .Location = "Log"
    .Body = Format("#" & dk) ' & Range("S1")
    '.Body = Format("#" & dk & "  is the docket number to research")
    .ReminderMinutesBeforeStart = 0.5 * 60 '1 hours times 60 minutes
    .Start = Format(dt + 8.5 / 24, "mm/dd/yyyy hh:mm")
    .End = Format(dt + 9 / 24, "mm/dd/yyyy hh:mm")
   
    .AllDayEvent = False
    .Save
    Sheets("Log").Protect Password:="test"
End With


Exit Sub
erHandle:
If Err.Number = 13 Then
    MsgBox "Active cell must containt a date", vbCritical
Else
    MsgBox "Error #" & Err.Number & vbCrLf & Err.Description
End If

Case vbNo
 GoTo Quit:
 End Select
 Sheets("Log").Protect Password:="test"
Quit:


End Sub

[maniacb]

any chance you can share an example file? See yellow banner above. So you want to send a reminder for the active row?

[lilsnoop]

maniacb-I've attached a sample workbook below. Thanks for taking the time to help!

[maniacb]

Give this a try

Sub CreateAppt()
On Error GoTo erHandle
Dim olApp As Object
Dim olItem As Object
Dim dt As Date
Dim dk As String
Dim Msg As String, Ans As Variant

 Msg = "Do you want to set an appointment reminder?"
 Ans = MsgBox(Msg, vbYesNo)
 Select Case Ans
 Case vbYes
dt = Cells(Selection.Row, "G").Value 'Range("S1").Value
dk = Cells(Selection.Row, "F").Value & "-" & Cells(Selection.Row, "H").Value 'Range("S2").Value
Set olApp = CreateObject("Outlook.Application")
Set olItem = olApp.CreateItem(1)


With olItem
    .Subject = Range("S3") 'Change to cell that has value for subject
    .Location = "Log"
    .Body = Format("#" & dk) ' & Range("S1")
    '.Body = Format("#" & dk & "  is the docket number to research")
    .ReminderMinutesBeforeStart = 0.5 * 60 '1 hours times 60 minutes
    .Start = Format(dt + 8.5 / 24, "mm/dd/yyyy hh:mm")
    .End = Format(dt + 9 / 24, "mm/dd/yyyy hh:mm")
   
    .AllDayEvent = False
    .Save
 
End With


Exit Sub
erHandle:
If Err.Number = 13 Then
    MsgBox "Active cell must containt a date", vbCritical
Else
    MsgBox "Error #" & Err.Number & vbCrLf & Err.Description
End If

Case vbNo
 GoTo Quit:
 End Select

Quit:


End Sub

[lilsnoop]

maniacb-That worked perfectly! Thank you!