Private Sub Worksheet_Calculate()
Dim aa As Range, bb As Range, b&, t1$
Application.EnableEvents = False
Set aa = Columns("D").Rows("2:" & Cells(Rows.Count, "D").End(xlUp).Row)
For Each bb In aa
  If IsDate(bb) Then
    If CDate(bb) <= Date - 2 Then b = b + 1
  End If
Next
If b >= 0.7 * aa.Cells.Count Then
  ThisWorkbook.Save
  For Each aa In Columns("G").Rows("2:" & Cells(Rows.Count, "G").End(xlUp).Row)
    t1 = t1 & aa & ";"
  Next
  SMail t1, "Сроки горят!", , ThisWorkbook.FullName
End If
Application.EnableEvents = True
End Sub
Sub SMail(ByVal adr1$, ByVal tema$, Optional ByVal adr2$, Optional ByVal iFile$, Optional ByVal iBody$)
    Dim objOutlookApp As Object, objMail As Object 'Автор - Дмитрий Щербаков
    On Error Resume Next
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear
    If objOutlookApp Is Nothing Then Set objOutlookApp = CreateObject("Outlook.Application")
    objOutlookApp.Session.Logon
    Set objMail = objOutlookApp.CreateItem(0)
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
    With objMail
      .To = adr1
      .cc = adr2
      .Subject = tema
      .Attachments.Add iFile
      On Error Resume Next
      .HTMLBody = iBody
      .Body = Activedocument.Content
      On Error GoTo 0
      .Send
    End With
    Set objOutlookApp = Nothing: Set objMail = Nothing
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim aa As Range, bb As Range, b&, t1$
Set aa = Columns("D").Rows("2:" & Cells(Rows.Count, "D").End(xlUp).Row)
If Not Intersect(Target, aa) Is Nothing Then
  For Each bb In aa
    If IsDate(bb) Then
      If CDate(bb) <= Date - 2 Then b = b + 1
    End If
  Next
  If b >= 0.7 * aa.Cells.Count Then
    ThisWorkbook.Save
    For Each aa In Columns("G").Rows("2:" & Cells(Rows.Count, "G").End(xlUp).Row)
      t1 = t1 & aa & ";"
    Next
    SMail t1, "Сроки горят!", , ThisWorkbook.FullName
  End If
End If
End Sub