Send email when due date met with the data copied from workbook

[hsolanki]

Hi all

I was wondering if anyone could kindly help me with the creating some code whereby when expiry Due Date in column J or Column L is due in 90 days then automated email is sent with the copying all of the information in the row each which has due date from Column A to Column M data copied on to the automated email.

and is something also when you select Complete or Leavers in Column AG then it is automatically cut that row and pasted onto the next available blank row in corresponding sheet e.g Completed or Leavers.

i have attached sample sample book

Sample Due Dates.xlsx

drive.google.com

Thank yo in advance

 

[hsolanki]

Good Morning everyone

can anyone please help me with my workbook as really struggling as i am not an expert on VBA.

Thank you

 

[hsolanki]

Hi everybody just to update on my 2nd question, it is resolved now.

Leaves blank rows after row with specific word moved to sheet 2

Hi everybody i have found this code from here and it works perfect however when it is cut it from Sheet 1 to Sheet 2 with specific word "Completed" it cut all the rows that contains "Completed" on column "AG" however it then leave the blanks rows on sheet1 is there any way that when it is moved...

www.mrexcel.com

i also have found below code and played around however the code it is not doing anything.

Sub Send_Table_autofilter_2()

Dim MailBody As Range
Dim dwn As Range

'If filtered remove filter. Throws error if not filtered
  ActiveSheet.Range("j1").Activate
  On Error Resume Next
  ActiveSheet.ShowAllData

Set mWs = Worksheets("Full")

'If MailBody sheet already exists then delete it
  If WorksheetExists("MailBody") Then
   Application.DisplayAlerts = False
    Worksheets("MailBody").Delete
   Application.DisplayAlerts = True
End If

'Add a sheet to copy all todays date rows to
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "MailBody"
 

'Return to the mail content sheet
   mWs.Activate

'Set range as column A to check for todays date. If yes is found skip filter and mail creation
Set Rng = Range(Range("j1"), Range("j" & Rows.Count).End(xlUp))
          
    For Each cell In Rng
   If cell.Value <= Date + 30 Then

    If Not cell.Offset(0, 1).Value = "yes" Then
   
   
'https://stackoverflow.com/questions/52340156/excel-macro-to-filter-column-to-todays-date
  With Worksheets("Sheet5")
    With Rng
    .AutoFilter field:=1, Criteria1:=xlFilterDate, Operator:=xlFilterDynamic
    End With
   End With
      
'Copy the autofilter range and header to the MailBody sheet
    Worksheets("Sheet5").AutoFilter.Range.Offset(0, 0).Copy Sheets("MailBody").Range("A1")
  
   
'Need to add yes to each autofiltered row and date. Column A is the range so offset by 10 and 11 columns.
    For Each dwn In Rng.SpecialCells(xlCellTypeVisible)
    Rng.Offset(0, 1).Value = "yes"
    Rng.Offset(0, 2).Value = Date
    Next
   
   
   ActiveSheet.Range("j2").Activate
   ActiveSheet.ShowAllData
              

' Change the following as needed
    sSendTo = "JoeBloggs@yahoo.co.uk"
    sSendCC = ""
    sSendBCC = ""
    sSubject = "Due date reached"
      
MsgStr = sTemp = "Hello!" & "<br><br>"
         sTemp = sTemp & "The due date has been reached "
         sTemp = sTemp & "for this project:" & "<br><br>"
' Assumes project name is in column B
         sTemp = sTemp & " " & Cells(lRow, 2)
         sTemp = sTemp & "Please take the appropriate"
         sTemp = sTemp & "action." & "<br><br>"
         sTemp = sTemp & "Thank you!" & "<br>"


'Set Range on MailBody Sheet, then autofit it before copying to mail
  With Worksheets("MailBody")
    lRow = .Range("A" & .Rows.Count).End(xlUp).Row
    
 Set MailBody = .Range(.Cells(1, 2), .Cells(lRow, 7)) 'Columns 2 to 7
'Set MailBody = .Range(.Cells(1, 1), .Cells(lRow, 10)) - Columns 1 to 10
  End With
 
  MailBody.Columns.AutoFit
   
                      
'Create mail
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
   
        With OutMail
            .To = sSendTo
            .CC = sSendCC
            .Subject = sSubject
            .HTMLBody = sTemp & RangetoHTML(MailBody)
            .Display
        'send
       End With
          
          
  End If
End If


MailTo = ""
MailSubject = ""
Next


'Delete MailBody sheet
Application.DisplayAlerts = False
' Worksheets("MailBody").Delete
Application.DisplayAlerts = True
End Sub


Function RangetoHTML(Rng As Range) ' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
'Function from - https://www.rondebruin.nl/win/s1/outlook/bmail2.htm

    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook


    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"


    'Copy the range and create a new workbook to past the data in
   
    Rng.Copy
   
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial -4163, , False, False
        .Cells(1).PasteSpecial -4122, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With


    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=4, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=0)
        .Publish (True)
    End With


    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")


    'Close TempWB
    TempWB.Close savechanges:=False


    'Delete the htm file we used in this function
    Kill TempFile


    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

'Does the worksheet exists
    Function WorksheetExists(WSName) As Boolean
        On Error Resume Next
        WorksheetExists = Worksheets(WSName).Name = WSName
    On Error GoTo 0
    End Function