Can some please help....I am working on a short deadline.
My table:
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD][/TD]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]A gentle Reminder:[/TD]
[TD]Your trip is scheduled in two weeks[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]Destination[/TD]
[TD]Date[/TD]
[TD]Days[/TD]
[TD]Reminder[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]Boston[/TD]
[TD]8/18/2018[/TD]
[TD]10[/TD]
[TD]Send Reminder[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]New York[/TD]
[TD]8/18/2018[/TD]
[TD]10[/TD]
[TD]Send Reminder[/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD]South Africa[/TD]
[TD]9/20/2018[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
My code to do what I need this table to do:
Sub datesexcelvba()
Dim OutLookApp As Object
Dim OutLookMailItem As Object
Dim icounter As Integer
Dim maildest As String
Dim mydate1 As Date
Dim mydate2 As Long
Dim datetoday1 As Date
Dim datetoday2 As Long
Dim cell As Range
Dim Subj As String
Dim Msg As String
This part of the table is causing an error message to come up (HOWEVER ITS THE MOST IMPORTANT PART)
LR = Range("D" & Rows.Count).End(x1UP).Row
For Each cell In Range("D3:D" & LR)
If Reminder(cell) = "Send Reminder" Then
Pos = WorksheetFunction.Find("", cell.Offset(, -1))
FName = Left(cell.Offset(, -1), Pos - 1)
Subject = "Friendly Reminder that this"
Msg = "This Property " & FName & "," & vbNewLine
Msg = Msg & vbNewLine & " is schedule to begin Rapid Rehab in two weeks. Have a wonderful day." & vbCrLf & vbCrLf
Dim x As Long
lastrow = Sheets("Ok-Green").Cells(Rows.Count, 1).End(xlUp).Row
For x = 3 To lastrow
mydate1 = Cells(x, 2).Value
mydate2 = mydate1
Cells(x, 6).Value = mydate2
datetoday1 = Date
datetoday2 = datetoday1
Cells(x, 7).Value = datetoday2
If mydate2 - datetoday2 = 10 Then
Set OutLookApp = CreateObject("Outlook.application")
Set OutLookMailItem = OutLookApp.createitem(OlMailItem)
Cells(x, 4) = "Send Reminder"
Cells(x, 3).Interior.ColorIndex = 3
Cells(x, 3).Font.ColorIndex = 2
Cells(x, 3).Font.Bold = True
Cells(x, 3).Value = mydate2 - datetoday2
End If
Next
Set myApp = Nothing
Set mymail = Nothing
Set OutLookApp = CreateObject("Outlook.application")
Set OutLookMailItem = OutLookApp.createitem(OlMailItem)
MailDest1 = "mindy2017art@gmail.com"
MailDest2 = "mindy2017art@gmail.com"
With OutLookMailItem
.to = MailDest1
.bcc = MailDest2
.Subject = Range("a1").Value
.Body = Range("B1").Value
'.send
.display
End With
Set OutLookMailItem = Nothing
Set OutLookApp = Nothing
End Sub
My table:
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD][/TD]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]A gentle Reminder:[/TD]
[TD]Your trip is scheduled in two weeks[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]Destination[/TD]
[TD]Date[/TD]
[TD]Days[/TD]
[TD]Reminder[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]Boston[/TD]
[TD]8/18/2018[/TD]
[TD]10[/TD]
[TD]Send Reminder[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]New York[/TD]
[TD]8/18/2018[/TD]
[TD]10[/TD]
[TD]Send Reminder[/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD]South Africa[/TD]
[TD]9/20/2018[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
My code to do what I need this table to do:
Sub datesexcelvba()
Dim OutLookApp As Object
Dim OutLookMailItem As Object
Dim icounter As Integer
Dim maildest As String
Dim mydate1 As Date
Dim mydate2 As Long
Dim datetoday1 As Date
Dim datetoday2 As Long
Dim cell As Range
Dim Subj As String
Dim Msg As String
This part of the table is causing an error message to come up (HOWEVER ITS THE MOST IMPORTANT PART)
LR = Range("D" & Rows.Count).End(x1UP).Row
For Each cell In Range("D3:D" & LR)
If Reminder(cell) = "Send Reminder" Then
Pos = WorksheetFunction.Find("", cell.Offset(, -1))
FName = Left(cell.Offset(, -1), Pos - 1)
Subject = "Friendly Reminder that this"
Msg = "This Property " & FName & "," & vbNewLine
Msg = Msg & vbNewLine & " is schedule to begin Rapid Rehab in two weeks. Have a wonderful day." & vbCrLf & vbCrLf
Dim x As Long
lastrow = Sheets("Ok-Green").Cells(Rows.Count, 1).End(xlUp).Row
For x = 3 To lastrow
mydate1 = Cells(x, 2).Value
mydate2 = mydate1
Cells(x, 6).Value = mydate2
datetoday1 = Date
datetoday2 = datetoday1
Cells(x, 7).Value = datetoday2
If mydate2 - datetoday2 = 10 Then
Set OutLookApp = CreateObject("Outlook.application")
Set OutLookMailItem = OutLookApp.createitem(OlMailItem)
Cells(x, 4) = "Send Reminder"
Cells(x, 3).Interior.ColorIndex = 3
Cells(x, 3).Font.ColorIndex = 2
Cells(x, 3).Font.Bold = True
Cells(x, 3).Value = mydate2 - datetoday2
End If
Next
Set myApp = Nothing
Set mymail = Nothing
Set OutLookApp = CreateObject("Outlook.application")
Set OutLookMailItem = OutLookApp.createitem(OlMailItem)
MailDest1 = "mindy2017art@gmail.com"
MailDest2 = "mindy2017art@gmail.com"
With OutLookMailItem
.to = MailDest1
.bcc = MailDest2
.Subject = Range("a1").Value
.Body = Range("B1").Value
'.send
.display
End With
Set OutLookMailItem = Nothing
Set OutLookApp = Nothing
End Sub