Email based on Criteria ....

prakash24 · Nov 25th 2017

[SIZE=13px]Hi All,[/SIZE]

[SIZE=13px]I want to do Auto-email as reminder msg for others, My Data is in merged cells , At Column G I have a formula that calculate number of days left , I want whenever column G values reaches to 100 , an auto email with predefined msg should sent for multiple serial number at same time if there values also reached 100 . this is a shared workbook with multiple user access ,need email to be send from one set user not from other user and using only my signature while auto email .Can It be done using macro.[/SIZE]

[SIZE=13px]I have a attachment Please Have a look .[/SIZE]

[SIZE=13px]Thank you [/SIZE]

**Kenneth Hobson** · Nov 25th 2017

I don't know what the multiple serial number at same time means. This just does it each one where column G <= 100 and not in the log sheet.

You need the log sheet to have a unique number to make sure that it does not resend the next time is is ran. I used serial number. If you don't do something like that, then you need a helper column to mark that shows email was sent.

Obviously, change the value in the INPUT commented block and modify the Body value to suit. Uncomment .Sent and delete or comment out .Display when it works as needed.

Always test in a backup copy, and put this in a Module. You may want to put a call to it in ThisWorkbook's Open event.

Code

Sub EmailByDateDue()
  Dim ws As Worksheet, ws2 As Worksheet, r As Range, c As Range
  Dim f As Range, sig$, SentOnBehalfOfName$, body$, user$
  'Tools > References > Microsoft Outlook xx.0 Object Library
  Dim olApp As Outlook.Application, olMail As Outlook.MailItem
  'Tools > References > Microsoft Word xx.0 Object Library
  Dim Word As Document, wr As Word.Range


'****************** INPUTs ***************************************
  Set ws = Worksheets("Data")
  Set ws2 = Worksheets("Email sent Report")
  'Signature file path, must exist.
  SentOnBehalfOfName = "[email protected]"
  sig = ThisWorkbook.Path & "\sig.rtf"
  user = Environ("username")
'****************** END INPUTs ***********************************


  If user <> "Kenneth Hobson" Then Exit Sub


  '100 day column
  Set r = ws.Range("G2", ws.Cells(Rows.Count, "G").End(xlUp))


  Set olApp = New Outlook.Application


  For Each c In r
    If c > 100 Then GoTo NextC  'Not due yet so skip.
    Set f = ws2.Columns("A").Find(ws.Cells(c.Row, "A"), ws2.[A1])
    If Not f Is Nothing Then GoTo NextC


    Set olMail = olApp.CreateItem(olMailItem)
    With olMail
      .Importance = olImportanceNormal
      .To = ws.Cells(c.Row + 1, "C")
      .SentOnBehalfOfName = SentOnBehalfOfName
      .Subject = "100 Day Reminder"
      body = "Name: " & ws.Cells(c.Row, "C") & vbCrLf
      body = body & "Amount: " & ws.Cells(c.Row, "D") & vbCrLf
      body = body & "Serial No.: " & ws.Cells(c.Row, "A")


      .GetInspector.Display
      Set Word = .GetInspector.WordEditor
      Set wr = Word.Content
      wr = body


      GetObject(sig).Content.Copy
      wr.Collapse Direction:=wdCollapseEnd
      wr.Paste  'Paste at end


      'https://msdn.microsoft.com/en-us/library/microsoft.office.interop.outlook._mailitem.deferreddeliverytime.aspx?cs-save-lang=1&cs-lang=vb#code-snippet-1
      .DeferredDeliveryTime = Now + TimeValue("00:10:00")
      .Display
      '.Send


      'Write entry to log sheet.
      Set f = ws2.Cells(Rows.Count, "A").End(xlUp).Offset(1)
      f = ws.Cells(c.Row, "A")  'Serial Number
      f.Offset(, 1) = ws.Cells(c.Row, "C") 'Name
      f.Offset(, 2) = ws.Cells(c.Row + 1, "C") 'Email
      f.Offset(, 3) = Date 'Reminder Sent
      f.Offset(, 3).NumberFormat = "mm/dd/yyyy"
    End With
NextC:
  Next c


  On Error Resume Next
  Set olMail = Nothing
  Set olApp = Nothing
End Sub

Display More

prakash24 · Nov 26th 2017

Quote from Kenneth Hobson

Hello Sir, I also tried the code to

[SIZE=13px]call in ThisWorkbook's Open event. it still showing error.[/SIZE]

**Kenneth Hobson** · Nov 26th 2017

Showing error is not very helpful. From the pics that you sent in PM to me, it is obvious that you did not add the 2 references as shown by the error message. My comments in the code for Dim show how to add the Outlook and Work object references.

prakash24 · Nov 26th 2017

[SIZE=13px]

Quote from Kenneth Hobson

[/SIZE]

[SIZE=13px]Hello Sir , I added 2 references for outlook and word object as references. and tried to change the date to 100 .there is No error no but email not going. Now what can be the possible issue?? [/SIZE]

[SIZE=13px]As I have login name and password for every user to access workbook/[/SIZE]

[SIZE=13px] user = Environ("userPC") ----here I should enter username or Pc name ??...[/SIZE]

[SIZE=13px]'****************** END INPUTs ***********************************[/SIZE]

[SIZE=13px] If user <> "Lalit" ----username?? [/SIZE]

[SIZE=13px]or both should be same .[/SIZE]

[SIZE=13px]Thank you[/SIZE]

**Kenneth Hobson** · Nov 26th 2017

Environ() gets well, your environment variable's value. Environ("username")=%username%. Type %username% in Exploerer (Win+E) and press enterkey. Or, in VBE's Immediate Window (Ctrl+G) type:

Code

?Environ("username")

and press enterkey.

If you want to let anyone that uses that computer to do it, then replace username with computername.

prakash24 · Nov 26th 2017

Quote from Kenneth Hobson

sorry to disturb you sir. I am trying something like this one code with only username Name which is access for workbook at both place and one code for userPC name with user login id in workbook. Please check sir what I am doing Wrong ..

Code

user = Environ("lait")


'****************** END INPUTs ***********************************


  If user <> "lait" Then Exit Sub

Code

Environ("lalitcomputer")


'****************** END INPUTs ***********************************


  If user <> "lait" Then Exit Sub

prakash24 · Nov 26th 2017

Quote from Kenneth Hobson
Environ() gets well, your environment variable's value. Environ("username")=%username%. Type %username% in Exploerer (Win+E) and press enterkey. Or, in VBE's Immediate Window (Ctrl+G) type:
Code
?Environ("username")
and press enterkey..

Code

user = Environ("username") then Ctrl-G ---( [align=left][COLOR=#252C2F][FONT=Courier][SIZE=12px]?Environ("lalitcomputer"))[/SIZE][/FONT][/COLOR][/align]
 


'****************** END INPUTs ***********************************


  If user <> "lait" Then Exit Sub ----user id

I tried all but still something not working sir.

**Kenneth Hobson** · Nov 26th 2017

Do you not use the Immediate Window? It can be opened in the View menu or Ctrl+G. In it a question mark is the same as Debug.Print. Use it to test/debug things. MsgBox() can be used as a debug tool as well. Of course the Watch window can be used as well to debug. After a Run, view the Immediate window (Ctrl+G) Debug.Print's results.

e.g.

Code

Sub Env()
  Dim u$, c$


  u = Environ("username")
  c = Environ("computername")


  MsgBox u, vbInformation, "username"
  Debug.Print u, "username"
  MsgBox c, vbInformation, "computername"
  Debug.Print c, "computername"


  MsgBox u = "lenovo1"
End Sub

Display More

prakash24 · Nov 26th 2017

Quote from Kenneth Hobson

Thank you sir,
sometime my outlook get open but not sending any email automatically, recipient To is empty and
sometime shows GetObject(sig).Content.Copy Error ....I already gave a signature path ...

**Kenneth Hobson** · Nov 26th 2017

Just because you gave it a path does not mean that the path exists. It can be checked using Dir(sig)<>"".

IF .To="" then skip it.

Examples for both in snippets from post #2.:

Code

If user <> "Kenneth Hobson" Then Exit Sub
If Dir(sig) = "" Then
  MsgBox "Sig file does not exist, macro ending.", vbCritical, sig
  Exit Sub
End If


For Each c In r
  If c > 100 Then GoTo NextC  'Not due yet so skip.
  If ws.Cells(c.Row + 1, "C")="" Then GoTo NextC '.To value is missing, skip sending it.

prakash24 · Nov 27th 2017

Quote from Kenneth Hobson

Good Morning Sir, Wish You a Wonderful Day.
Sir I tried to insert the code but still getting the same error.. Please check.

Code

Sub EmailByDateDue()
  Dim ws As Worksheet, ws2 As Worksheet, r As Range, c As Range
  Dim u$, d$
  Dim f As Range, sig$, SentOnBehalfOfName$, body$, user$
  'Tools > References > Microsoft Outlook xx.0 Object Library
  Dim olApp As Outlook.Application, olMail As Outlook.MailItem
  'Tools > References > Microsoft Word xx.0 Object Library
  Dim Word As Document, wr As Word.Range


'****************** INPUTs ***************************************
  Set ws = Worksheets("Data")
  Set ws2 = Worksheets("Email sent Report")
  'Signature file path, must exist.
  SentOnBehalfOfName = "[email protected]"
  sig = ThisWorkbook.Path & "C:\Users\PrakashPC\AppData\Roaming\Microsoft\Signatures\Signature.rtf"
  u = Environ("username")
  d = Environ("computername")


  MsgBox u, vbInformation, "username"
  Debug.Print u, "username"
  MsgBox d, vbInformation, "computername"
  Debug.Print d, "computername"


  MsgBox u = "lenovo1"


  user = Environ("username")
'****************** END INPUTs ***********************************


  If user <> "Prakash" Then Exit Sub
  If Dir(sig) = "" Then
  MsgBox "Sig file does not exist, macro ending.", vbCritical, sig
  Exit Sub
End If


  '100 day column
  Set r = ws.Range("G2", ws.Cells(Rows.Count, "G").End(xlUp))


  Set olApp = New Outlook.Application


  For Each c In r
    If c > 100 Then GoTo NextC  'Not due yet so skip.
    Set f = ws2.Columns("A").Find(ws.Cells(c.Row, "A"), ws2.[A1])
    If ws.Cells(c.Row + 1, "C") = "" Then GoTo NextC '.To value is missing, skip sending it.


    Set olMail = olApp.CreateItem(olMailItem)
    With olMail
      .Importance = olImportanceNormal
      .To = ws.Cells(c.Row + 1, "C")
      .SentOnBehalfOfName = SentOnBehalfOfName
      .Subject = "100 Day Reminder"
      body = "Name: " & ws.Cells(c.Row, "C") & vbCrLf
      body = body & "Amount: " & ws.Cells(c.Row, "D") & vbCrLf
      body = body & "Serial No.: " & ws.Cells(c.Row, "A")


      .GetInspector.Display
      Set Word = .GetInspector.WordEditor
      Set wr = Word.Content
      wr = body


      GetObject(sig).Content.Copy
      wr.Collapse Direction:=wdCollapseEnd
      wr.Paste  'Paste at end


      'https://msdn.microsoft.com/en-us/library/microsoft.office.interop.outlook._mailitem.deferreddeliverytime.aspx?cs-save-lang=1&cs-lang=vb#code-snippet-1
      .DeferredDeliveryTime = Now + TimeValue("00:10:00")
      .Display
      '.Send


      'Write entry to log sheet.
      Set f = ws2.Cells(Rows.Count, "A").End(xlUp).Offset(1)
      f = ws.Cells(c.Row, "A")  'Serial Number
      f.Offset(, 1) = ws.Cells(c.Row, "C") 'Name
      f.Offset(, 2) = ws.Cells(c.Row + 1, "C") 'Email
      f.Offset(, 3) = Date 'Reminder Sent
      f.Offset(, 3).NumberFormat = "mm/dd/yyyy"
    End With
NextC:
  Next c


  On Error Resume Next
  Set olMail = Nothing
  Set olApp = Nothing
End Sub

Display More

**Kenneth Hobson** · Nov 27th 2017

Obviously, the path is incorrect. Maybe remove one of the two paths? e.g.

Code

sig = "C:\Users\PrakashPC\AppData\Roaming\Microsoft\Signatures\Signature.rtf"

If you are not the user PrakashPC then that path will error too.

prakash24 · Nov 28th 2017

Hello sir ,
Now the maco is started to work Just tested and recived 1st email with signature without any error in code but there is few thing happening here..

1) Macro is trying to send email to All serial numbers whether its day reached to 100 or below "all" and keeping the outllook open for all emails after sendings also. Can we put the range 95days to 100 day only .
2) Sometime when macro is running for all serial number , its skipping between Email Id and contact number "somtime taking Email Id and somtime taking contact number at reciepent"

Thankyou sir for the Code .

Code

Sub EmailByDateDue()
  Dim ws As Worksheet, ws2 As Worksheet, r As Range, c As Range
  Dim u$, d$
  Dim f As Range, sig$, SentOnBehalfOfName$, body$, user$
  'Tools > References > Microsoft Outlook xx.0 Object Library
  Dim olApp As Outlook.Application, olMail As Outlook.MailItem
  'Tools > References > Microsoft Word xx.0 Object Library
  Dim Word As Document, wr As Word.Range


'****************** INPUTs ***************************************
  Set ws = Worksheets("Data")
  Set ws2 = Worksheets("Email sent Report")
  'Signature file path, must exist.
  SentOnBehalfOfName = "[email protected]"
  sig = "C:\Users\PrakashPC\Desktop\New folder\Signature.rtf"
  u = Environ("username")
  d = Environ("computername")


  MsgBox u, vbInformation, "username"
  Debug.Print u, "username"
  MsgBox d, vbInformation, "computername"
  Debug.Print d, "computername"


  MsgBox u = "lenovo1"


  user = Environ("username")
'****************** END INPUTs ***********************************


  If user <> "PrakashPC" Then Exit Sub
  If Dir("C:\Users\PrakashPC\Desktop\New folder\Signature.rtf") = "" Then
  MsgBox "Sig file does not exist, macro ending.", vbCritical, sig
  Exit Sub
End If


  '100 day column
  Set r = ws.Range("G2", ws.Cells(Rows.Count, "G").End(xlUp))


  Set olApp = New Outlook.Application


  For Each c In r
    If c > 100 Then GoTo NextC  'Not due yet so skip.
    Set f = ws2.Columns("A").Find(ws.Cells(c.Row, "A"), ws2.[A1])
    If ws.Cells(c.Row + 1, "C") = "" Then GoTo NextC '.To value is missing, skip sending it.


    Set olMail = olApp.CreateItem(olMailItem)
    With olMail
      .Importance = olImportanceNormal
      .To = ws.Cells(c.Row + 1, "C")
      .SentOnBehalfOfName = SentOnBehalfOfName
      .Subject = "100 Day Reminder"
      body = "Name: " & ws.Cells(c.Row, "C") & vbCrLf
      body = body & "Amount: " & ws.Cells(c.Row, "D") & vbCrLf
      body = body & "Serial No.: " & ws.Cells(c.Row, "A")


      .GetInspector.Display
      Set Word = .GetInspector.WordEditor
      Set wr = Word.Content
      wr = body


      GetObject("C:\Users\PrakashPC\Desktop\New folder\Signature.rtf").Content.Copy
      wr.Collapse Direction:=wdCollapseEnd
      wr.Paste  'Paste at end
      '.Send


      'https://msdn.microsoft.com/en-us/library/microsoft.office.interop.outlook._mailitem.deferreddeliverytime.aspx?cs-save-lang=1&cs-lang=vb#code-snippet-1
      .DeferredDeliveryTime = Now + TimeValue("00:10:00")
      .Display
      '.Send


      'Write entry to log sheet.
      Set f = ws2.Cells(Rows.Count, "A").End(xlUp).Offset(1)
      f = ws.Cells(c.Row, "A")  'Serial Number
      f.Offset(, 1) = ws.Cells(c.Row, "C") 'Name
      f.Offset(, 2) = ws.Cells(c.Row + 1, "C") 'Email
      f.Offset(, 3) = Date 'Reminder Sent
      f.Offset(, 3).NumberFormat = "mm/dd/yyyy"
    End With
NextC:
  Next c


  On Error Resume Next
  Set olMail = Nothing
  Set olApp = Nothing
End Sub

Display More

**Kenneth Hobson** · Nov 28th 2017

For (1):

Code

'If c > 100 Then GoTo NextC  'Not due yet so skip.
    If c < 95 Or c > 100 Then GoTo NextC 'Not due yet so skip.

You may want to delete or comment out the DeferredDeliveryTime and the .Display and uncomment the .Send.

As for (2), it works as expected for me using your example file. If you change the structure of your data sheet, then things will go amiss.

prakash24 · Nov 28th 2017

Really Thank you sir now its working perfectly ,

[SIZE=13px]the email are going as I wanted [/SIZE]

, but the only missing thing is As I call the macro in open workbook , every time I open the workbook its sending the email again or twice to the same serial number which is already been sent before.

Sir to control it you already gave a solution
"[SIZE=13px]You need the log sheet to have a unique number to make sure that it does not resend the next time is ran. I used serial number. If you don't do something like that, then you need a helper column to mark that shows email was sent." but how I can implement it so that it should not go twice to the same Serial number" .[/SIZE]

[SIZE=13px]How Can I Add a helper column or unique numbers?

Please Assist.[/SIZE]

**Kenneth Hobson** · Nov 28th 2017

I get a notice when there are posts to a thread that I participate in. So, there is no reason to PM me as well.

If you never delete the master data, a simple formula like =Row() will give you a unique number. Your log sheet would then need a column for that. The code would use Filter() like I did for Serial Number or a CountIf(), Another way to get a unique number is via a macro.

Add the two columns and formulas to your example file and attach if you need help changing the code to work with it.

prakash24 · Nov 28th 2017

Sir, I added two extra Column in my Log sheet for unique number =row() and formula countif,. Please have a look.

Sir, we always Change the master data with New start and End date , and sometime we also change name and email Address , to give a person the new time frame every time for each serial number to finish things ontime and we remind them by email when only 100 days left.

**Kenneth Hobson** · Nov 28th 2017

The formula for unique numbers is for the Data sheet, not the Log sheet. The count column on Log sheet is redundant as the count would never exceed 1.

On the Data sheet, I added the unique formula starting in H2. =IF(A2="","",ROW())

I added back the line to skip emailing if the unique value was in the Log sheet and made a few other small changes. Now, if sig file does not exist, it will just not attach it.

Code

Sub EmailByDateDue2()
  Dim ws As Worksheet, ws2 As Worksheet, r As Range, c As Range
  Dim u$, d$
  Dim f As Range, sig$, SentOnBehalfOfName$, body$, user$
  'Tools > References > Microsoft Outlook xx.0 Object Library
  Dim olApp As Outlook.Application, olMail As Outlook.MailItem
  'Tools > References > Microsoft Word xx.0 Object Library
  Dim Word As Document, wr As Word.Range


'****************** INPUTs ***************************************
  Set ws = Worksheets("Data")
  Set ws2 = Worksheets("Email sent Report")
  SentOnBehalfOfName = "[email protected]"
  sig = "C:\Users\PrakashPC\Desktop\New folder\Signature.rtf"
  u = Environ("username")
  d = Environ("computername")


  user = Environ("username")
'****************** END INPUTs ***********************************


  If user <> "PrakashPC" Then Exit Sub


  '95-100 day column
  Set r = ws.Range("G2", ws.Cells(Rows.Count, "G").End(xlUp))


  Set olApp = New Outlook.Application


  For Each c In r
    If c < 95 Or c > 100 Then GoTo NextC 'Not due yet so skip.
    Set f = ws2.Columns("E").Find(ws.Cells(c.Row, "H"), ws2.[E1])
    If Not f Is Nothing Then GoTo NextC
    If ws.Cells(c.Row + 1, "C") = "" Then GoTo NextC '.To value is missing, skip sending it.


    Set olMail = olApp.CreateItem(olMailItem)
    With olMail
      .Importance = olImportanceNormal
      .To = ws.Cells(c.Row + 1, "C")
      .SentOnBehalfOfName = SentOnBehalfOfName
      .Subject = "95-100 Day Reminder"
      body = "Name: " & ws.Cells(c.Row, "C") & vbCrLf
      body = body & "Amount: " & ws.Cells(c.Row, "D") & vbCrLf
      body = body & "Serial No.: " & ws.Cells(c.Row, "A")


      .GetInspector.Display
      Set Word = .GetInspector.WordEditor
      Set wr = Word.Content
      wr = body


      If Dir(sig) <> "" Then
        GetObject("C:\Users\PrakashPC\Desktop\New folder\Signature.rtf").Content.Copy
        wr.Collapse Direction:=wdCollapseEnd
        wr.Paste  'Paste at end
      End If


      '.Display
      'https://msdn.microsoft.com/en-us/library/microsoft.office.interop.outlook._mailitem.deferreddeliverytime.aspx?cs-save-lang=1&cs-lang=vb#code-snippet-1
      .Send


      'Write entry to log sheet.
      Set f = ws2.Cells(Rows.Count, "A").End(xlUp).Offset(1)
      f = ws.Cells(c.Row, "A")  'Serial Number
      f.Offset(, 1) = ws.Cells(c.Row, "C") 'Name
      f.Offset(, 2) = ws.Cells(c.Row + 1, "C") 'Email
      f.Offset(, 3) = Date 'Reminder Sent
      f.Offset(, 3).NumberFormat = "mm/dd/yyyy"
      f.Offset(, 4) = ws.Cells(c.Row, "H")
    End With
NextC:
  Next c


  On Error Resume Next
  Set olMail = Nothing
  Set olApp = Nothing
End Sub

Display More

prakash24 · Nov 29th 2017

Thank you so much sir ,its Working amazing now everything is Working perfect just want to know few things

1) How unique number are working to stop the macro for sending it twice to same email.?

2) after sending email ,if we later increase the number of days left mean changes in start and end date , we Also first have to remove the entry from log sheet ? Is there any way that the full log sheet get clear by itself in every 2 month or 3 months on selected day.

3) If I want to CC one or more people ,how can I do it ?

4) sir as we have user as PrakashPC can we also add excel user there because to login in workbook i have different excel id/username?

Email based on Criteria ....

Participate now!

Share

Users Viewing This Thread