Code to email projects that are due
I have some code that I have tried to piece together and I am having some issues getting it to do what it should do.
Here is what I am expecting:
Clear contents (if any) previously pasted to sheet 2
switch active sheet to sheet 1 and find all column D rows with data in them
find out if the date in each of the rows with data in it is within 14 days of today's date
if yes, select the value in column A
copy all selected values to sheet 2
take the values copied onto page 2 and insert them into the body of an email and send it
So far the code doesn't work past the first section to clear data in the rows. Not sure if any of the rest works.
Goals:
1. Automatically send a report of projects due within 14 days via email so that their status can be checked
2. Take similar code, but remove the email portion, to pop up a message and ask for input on past due projects and if they are complete; this would only apply to projects that didn't have a given value in a different column (I am planning to try and modify this code to simply do something slightly different than this code)
Help would be appreciated.
Related Post: http://excelexperts.com/how-create-macro-trigger-emails-based-dates-exce...
[code]
Sub Email_Report()
'Working in Excel 2002-2013
Dim AWorksheet As Worksheet
Dim Sendrng As Range
Dim rng As Range
Dim lastRow As Range
Dim firstRow As Range
Dim lastRow2 As Range
Dim firstRow2 As Range
Dim needByDate As Boolean
Dim dFR As Range
Dim dLR As Range
Set AWorksheet = Sheets("Sheet2")
Set firstRow = AWorksheet.Cells(Rows.Count, "A").End(xlDown).Row
Set lastRow = AWorksheet.Cells(Rows.Count, "A").End(xlUp).Row
AWorksheet.Cells("A" & firstRow, "A" & lastRow).Select
Selection.ClearContents
Set AWorksheet = Sheets("Sheet1")
dFR = AWorksheet.Cells(Rows.Count, "D").End(xlDown).Row + 1
dLR = AWorksheet.Cells(Rows.Count, "D").End(xlUp).Row
For i = dFR To dLR Step 1
If AWorksheet.Cells(i, "D").Value <= Date - 14 Then
AWorksheet.Cells(i, "A").Select
End If
Next i
Selction.Copy
Set AWorksheet = Worksheets("Sheet2").Range("A1")
ActiveSheet.Paste
Set AWorksheet = Worksheets("Sheet1")
On Error GoTo StopMacro
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
firstRow2 = AWorksheet.Cells(Rows.Count, "A").End(xlDown).Row + 1
lastRow2 = AWorksheet.Cells(Rows.Count, "A").End(xlUp).Row
'Fill in the Worksheet/range you want to mail
'Note: if you use one cell it will send the whole worksheet
Set Sendrng = Worksheets("Sheet2").Range("A" & (firstRow), "A" & (lastRow))
'Remember the activesheet
Set AWorksheet = ActiveSheet
With Sendrng
' Select the worksheet with the range you want to send
.Parent.Select
'Remember the ActiveCell on that worksheet
Set rng = ActiveCell
'Select the range you want to mail
.Select
' Create the mail and send it
ActiveWorkbook.EnvelopeVisible = True
With .Parent.MailEnvelope
' Set the optional introduction field thats adds
' some header text to the email body.
.Introduction = "The following builds are due to land in 14 days, Have you processed the orders?"
With .Item
.to = ""
.CC = ""
.BCC = ""
.Subject = "Builds Due"
.Send
End With
End With
'select the original ActiveCell
rng.Select
End With
'Activate the sheet that was active before you run the macro
AWorksheet.Select
StopMacro:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
ActiveWorkbook.EnvelopeVisible = False
End Sub
[/code]
Recent comments
5 years 36 weeks ago
6 years 22 weeks ago
6 years 34 weeks ago
6 years 37 weeks ago
6 years 38 weeks ago
6 years 43 weeks ago
6 years 52 weeks ago
7 years 2 days ago
7 years 3 days ago
7 years 3 days ago