Automatically send Mail for Due Dates from Excel

[Topazpower]

I have a workbook which consists of the due dates for which my employee has to be paid up.

Is it possible to generate a code which automatically sends an email from excel every day along with the employee name,employee ID and due date along with

the amount to be paid, which should go through the following:


Employee Id is in C2, C3, C4 and so on.... ( It is added periodically )

Employee Name is in D2, D3, D4 and so on....( It is added periodically )

Employee Salary is in J2, J3, J4, and so on....( It is added periodically )


Due Dates for 1st employee is feeded in k2,l2,m2,n2,o2,p2,q2 etc.....
2nd employee is feeded in k3,l3,m3,n3,o3,p3,q3 etc.....
3rd employee is feeded in k4,l4,m4,n4,o4,p4,q4 etc.....

and so on...


The report should be in two forms i.e., 7 days before due date


and

one month before due date.



Kindly help


Jane.

 

[Ed in Aus]

Can you supply some dates and also due dates. and formatting of dates

and supply more detail in regards to what information is in the sheet examples

How you update the sheet, might be best if you post the sheet if you can, before and after update and what you want to see in the email.

Excel tables to the web >> http://www.excel-jeanie-html.de/index.php?f=1

 

[Topazpower]

I would like to have the Employees name and Id numbers list along with the salary details payable which is due to them.

I need this list 7 days before the due date falls and the same list before a month of the due date falls.


Probably, Every week or every 3 days, new employees will be added. So, all Employees and their respective ids, salary and their due dates for salary will be added in a row one under the other.

I have attached the workbook herewith. Pls help.

Regards
Jane.

Excel Workbook
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG
1	S.No	Ref No	Employee ID	Employee Name	Days	OT	Basic	DOJ	Amount Payable	1st Due	2nd Due	3rd Due	4th	5th	6th	7th	8th	9th	10th	11th	12th	13th	14th	15th	16th	17th	18th	19th	20th	21st	22nd	23rd	24th
2	1	109	MDB100001	John	30	0	500	12-Mar-09	500	11-Apr-09	11-May-09	10-Jun-09	10-Jul-09	09-Aug-09	08-Sep-09	08-Oct-09	07-Nov-09	07-Dec-09	06-Jan-10	05-Feb-10	07-Mar-10	06-Apr-10	06-May-10	05-Jun-10	05-Jul-10	04-Aug-10	03-Sep-10	03-Oct-10	02-Nov-10	02-Dec-10	01-Jan-11	31-Jan-11	02-Mar-11
3	2	110	MDB100002	Rivera	30	0	500	14-Mar-09	500	13-Apr-09	13-May-09	12-Jun-09	12-Jul-09	11-Aug-09	10-Sep-09	10-Oct-09	09-Nov-09	09-Dec-09	08-Jan-10	07-Feb-10	09-Mar-10	08-Apr-10	08-May-10	07-Jun-10	07-Jul-10	06-Aug-10	05-Sep-10	05-Oct-10	04-Nov-10	04-Dec-10	03-Jan-11	02-Feb-11	04-Mar-11
4	3	111	MDB100003	Mary	30	0	500	14-Mar-09	500	13-Apr-09	13-May-09	12-Jun-09	12-Jul-09	11-Aug-09	10-Sep-09	10-Oct-09	09-Nov-09	09-Dec-09	08-Jan-10	07-Feb-10	09-Mar-10	08-Apr-10	08-May-10	07-Jun-10	07-Jul-10	06-Aug-10	05-Sep-10	05-Oct-10	04-Nov-10	04-Dec-10	03-Jan-11	02-Feb-11	04-Mar-11
5	4	112	MDB100004	Sweta	30	0	500	14-Mar-09	500	13-Apr-09	13-May-09	12-Jun-09	12-Jul-09	11-Aug-09	10-Sep-09	10-Oct-09	09-Nov-09	09-Dec-09	08-Jan-10	07-Feb-10	09-Mar-10	08-Apr-10	08-May-10	07-Jun-10	07-Jul-10	06-Aug-10	05-Sep-10	05-Oct-10	04-Nov-10	04-Dec-10	03-Jan-11	02-Feb-11	04-Mar-11
6	5	113	MDB100005	Brian	30	0	500	17-Mar-09	500	16-Apr-09	16-May-09	15-Jun-09	15-Jul-09	14-Aug-09	13-Sep-09	13-Oct-09	12-Nov-09	12-Dec-09	11-Jan-10	10-Feb-10	12-Mar-10	11-Apr-10	11-May-10	10-Jun-10	10-Jul-10	09-Aug-10	08-Sep-10	08-Oct-10	07-Nov-10	07-Dec-10	06-Jan-11	05-Feb-11	07-Mar-11
7	6	114	MDB100006	Fina	30	0	500	17-Mar-09	500	16-Apr-09	16-May-09	15-Jun-09	15-Jul-09	14-Aug-09	13-Sep-09	13-Oct-09	12-Nov-09	12-Dec-09	11-Jan-10	10-Feb-10	12-Mar-10	11-Apr-10	11-May-10	10-Jun-10	10-Jul-10	09-Aug-10	08-Sep-10	08-Oct-10	07-Nov-10	07-Dec-10	06-Jan-11	05-Feb-11	07-Mar-11
8	7
9	8
10	9
Sheet1

 

[Ed in Aus]

Ok this is what I have so far it is still in progress and one of the other guys could pick this up and tidy it up as I think there is a bit of clutter in it.

Sub test()
Dim r, c, r2, c2, r3 As Integer
r = 2
c = 10
r2 = 1
c2 = 1
r3 = 1
orig = ActiveSheet.Name
Sheets.Add.Name = ("Email")
Sheets(orig).Activate
'Week Due
Do Until Cells(r3, 1) = ""
If Cells(r, c) - Date < "0" Then
c = c + 1
ElseIf Cells(r, c) - Date < "7" Then
Rows(r).Copy
Sheets("Email").Activate
Rows(r2).PasteSpecial
Sheets(orig).Activate
r2 = r2 + 1
c2 = c2 + 1
c = c + 1
r = r + 1
End If
r3 = r3 + 1
Loop

End Sub

Please note that this is the first part... i.e getting out the people due for this week, just working on the email part then move onto the month sue part and email.

 

[Ed in Aus]

Ok here is what I have got... not sure if you wanted headers for the sheets emailed or if you wanted this info into the actual email but you can customise it so that weekly goes to one and monthly goes to another with an if statement if needed...

Please note that you will have to update the email address INSERT EMAIL ADDRESS HERE.

Sub test()
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim r, c, r2, c2, r3 As Integer
r = 2
c = 10
r2 = 1
c2 = 1
r3 = 1
orig = ActiveSheet.Name
Sheets.Add.Name = ("Email Weekly")
Sheets(orig).Activate
'Week Due
Do Until Cells(r3, 1) = ""
If Cells(r, c) - Date < "0" Then
c = c + 1
ElseIf Cells(r, c) - Date < "7" Then
Range("C" & r & " , D" & r & ", G" & r).Copy
Sheets("Email Weekly").Activate
Rows(r2).PasteSpecial
Sheets(orig).Activate
Rows(r).Delete
r2 = r2 + 1
c2 = c2 + 1
c = c + 1
r = r + 1
End If
r3 = r3 + 1
Loop
Sheets("Email Weekly").Activate
Application.Run "email"
Application.DisplayAlerts = False
Sheets("Email Weekly").Delete
Application.DisplayAlerts = True


Sheets.Add.Name = ("Email Monthly")
Sheets(orig).Activate
'Monthly Due
r = 2
c = 10
r2 = 1
c2 = 1
r3 = 1
Do Until Cells(r3, 1) = ""
If Cells(r, c) - Date > "7" Then
c = c + 1
ElseIf Cells(r, c) - Date < "30" Then

Range("C" & r & " , D" & r & ", G" & r).Copy
Sheets("Email Monthly").Activate
Rows(r2).PasteSpecial
Sheets(orig).Activate
r2 = r2 + 1
c2 = c2 + 1
c = c + 1
r = r + 1
End If
r3 = r3 + 1
Loop
Sheets("Email Monthly").Activate
Application.Run "email"
Application.DisplayAlerts = False
application.quit
Application.DisplayAlerts = True
End Sub
Sub email()
    'Emailing section
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set Sourcewb = ActiveWorkbook
    If ActiveSheet.Name = "Email Weekly" Then
    Subject = "Weekly Due"
    ElseIf ActiveSheet.Name = "Email Monthly" Then
    Subject = "Monthly Due"
    End If
    'Copy the sheet to a new workbook
    ActiveSheet.Copy
    Set Destwb = ActiveWorkbook

    'Determine the Excel version and file extension/format
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 97-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007, we exit the sub when your answer is
            'NO in the security dialog that you only see  when you copy
            'an sheet from a xlsm file with macro's disabled.
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "Your answer is NO in the security dialog"
                Exit Sub
            Else
                Select Case Sourcewb.FileFormat
                Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                Case 52:
                    If .HasVBProject Then
                        FileExtStr = ".xlsm": FileFormatNum = 52
                    Else
                        FileExtStr = ".xlsx": FileFormatNum = 51
                    End If
                Case 56: FileExtStr = ".xls": FileFormatNum = 56
                Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                End Select
            End If
        End If
    End With

    '    'Change all cells in the worksheet to values if you want
    '    With Destwb.Sheets(1).UsedRange
    '        .Cells.Copy
    '        .Cells.PasteSpecial xlPasteValues
    '        .Cells(1).Select
    '    End With
    '    Application.CutCopyMode = False

    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    TempFileName = Subject & " " & Sourcewb.Name & " " _
                 & Format(Now, "dd-mmm-yy h-mm-ss")

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, _
                FileFormat:=FileFormatNum
        On Error Resume Next
        .SendMail "INSERT EMAIL ADDRESS HERE", _
                  Subject
        On Error GoTo 0
        .Close SaveChanges:=False
    End With

    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub