Option Explicit
  
Sub Заявка()
Const TABLE_RANGE = "A7:H17"
  
Dim adressTo$, fname$, theme$, Disclaimer As Range
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim rng As Range
  
Set sh = ThisWorkbook.Sheets("Заявка")
  
With Application
    .DisplayAlerts = False
    .EnableEvents = False
    .ScreenUpdating = False
End With
  
With sh
    .AutoFilterMode = False
    .Range(TABLE_RANGE).AutoFilter Field:=2, Criteria1:="<>"
End With

Set rng = sh.Range(TABLE_RANGE).CurrentRegion
rng.Cells(1, rng.Columns.Count).Value = Replace(rng.Cells(1, rng.Columns.Count).Value, "передал", "отдал")

Dim adressCC As String
With sh
    adressTo = .Range("C1").Value
    adressCC = .Range("C2").Value
    theme = .Range("C3").Value
    Set Disclaimer = .Range("C4", "C5")
End With

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
  
Dim YourHTMLBody As String, iStart As Long, iEnd As Long
YourHTMLBody = RangetoHTML(Disclaimer, sh.Range(TABLE_RANGE))

With OutMail
    .To = adressTo
    .CC = adressCC
    .BCC = ""
    .Subject = theme
    .BodyFormat = 2
    .Display
    .HTMLBody = YourHTMLBody & .HTMLBody
 
End With
  
If rng.Rows.Count > 1 Then
    Set rng = rng.Cells(2, 2).Resize(rng.Rows.Count - 1, rng.Columns.Count - 1)
    With Sheets("Реестр")
        rng.Copy .Cells(.Rows.Count, 2).End(xlUp).Cells(2, 1)
    End With
End If
  
Set OutMail = Nothing
Set OutApp = Nothing
sh.AutoFilterMode = False
ThisWorkbook.Save
  
With Application
    .EnableEvents = True
    .ScreenUpdating = True
    .DisplayAlerts = True
End With
  
End Sub
  
Function RangetoHTML(head As Range, rng As Range) As String
    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"
    
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        CopyRange head, .Cells(1, 1)
        CopyRange rng, .Cells(3, 1)
         
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    
    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=")
    
    TempWB.Close savechanges:=False
    
    Kill TempFile
    
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
Private Sub CopyRange(rSource As Range, rTarget As Range)
    rSource.Copy
    With rTarget
        .PasteSpecial Paste:=8
        .PasteSpecial xlPasteValues, , False, False
        .PasteSpecial xlPasteFormats, , False, False
        .Select
    End With
    Application.CutCopyMode = False
End Sub

Disclaimer = .Range("C5").Value ' выбор текста сообщения

Sub Заявка()
Dim adressTo$, fname$, theme$, Disclaimer$
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim rng As Range

Set sh = ThisWorkbook.Sheets("Заявка")

With Application
    .DisplayAlerts = False
    .EnableEvents = False
    .ScreenUpdating = False
End With

With sh
    .AutoFilterMode = False
    .Range("$A$3:$B$3").AutoFilter Field:=2, Criteria1:="<>"
End With

Set rng = sh.Range("A3").CurrentRegion

With sh
    adressTo = .Range("P4").Value
    adressCC = .Range("P5").Value
    theme = .Range("C1").Value
    Disclaimer = .Range("C2").Value
End With

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next

Dim YourHTMLBody As String, iStart As Long, iEnd As Long

With OutMail
    .To = adressTo
    .CC = adressCC
    .BCC = ""
    .Subject = theme
    .BodyFormat = 2
    .Display
    YourHTMLBody = "<p style=font-size:11pt;font-family:Calibri;>" & Disclaimer & _
    RangetoHTML(rng) & vbCrLf & "<p style=font-size:11pt;font-family:Calibri;></a>"
    iStart = InStr(1, .HTMLBody, "<div class=WordSection1>", vbTextCompare)
    iEnd = InStr(1, .HTMLBody, "<p class=MsoNormal><a name=""_MailAutoSig"">", vbTextCompare)
    If iStart > 0 And iEnd > 0 Then
        .HTMLBody = Left(.HTMLBody, iStart - 1) & YourHTMLBody & Mid(.HTMLBody, iEnd)
    End If
    
End With

Set OutMail = Nothing
Set OutApp = Nothing
sh.AutoFilterMode = False
ThisWorkbook.Save

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

End Sub

With OutMail ' свойства элемента (письма)
    .To = adressTo ' получатель сообщения
    .CC = adressCC ' получатели копии сообщения
    .BCC = "" ' отправка элемента (письма) только основным получателям
    .Subject = theme
    .BodyFormat = 2 ' формат создаваемого элемента (письма) установить HTML
    .Display ' вставит подпись
    YourHTMLBody = "<p style=font-size:11pt;font-family:Calibri;>" & Disclaimer & _
    RangetoHTML(rng) & vbCrLf & "<p style=font-size:11pt;font-family:Calibri;></a>"
    iStart = InStr(1, .HTMLBody, "<div class=WordSection1>", vbTextCompare)
    iEnd = InStr(1, .HTMLBody, "<p class=MsoNormal><a name=""_MailAutoSig"">", vbTextCompare)
    If iStart > 0 And iEnd > 0 Then
        .HTMLBody = Left(.HTMLBody, iStart - 1) & YourHTMLBody & Mid(.HTMLBody, iEnd)
    End If
    
End With

Sub Проверка()
Dim adressTo$, fname$, theme$, Disclaimer$
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim rng As Range

Set sh = ThisWorkbook.Sheets("Расчет")

With Application
    .DisplayAlerts = False
    .EnableEvents = False
    .ScreenUpdating = False
End With

With sh
    .AutoFilterMode = False
    .Range("$A$3:$B$3").AutoFilter Field:=2, Criteria1:="<>" ' диапазон таблицы
End With

Set rng = sh.Range("A3").CurrentRegion

With sh
    adressTo = .Range("O3").Value ' получатель сообщения
    adressCC = .Range("O4").Value ' получатели копии сообщения
    theme = "согласование" & .Range("A4").Value & " " & .Range("T4").Value & " " & .Range("T5").Value & " " & .Range("T6").Value & " " & .Range("T7").Value & " " & .Range("T8").Value & " " & .Range("T9").Value & " " & .Range("T10").Value & " " & .Range("T11").Value & " " & .Range("T12").Value & " " & .Range("T13").Value & " " & .Range("T14").Value & " " & .Range("T15").Value & " " & .Range("T16").Value & " " & .Range("T17").Value & " " & .Range("T18").Value & " " & .Range("T19").Value & " " & .Range("T20").Value & " " & .Range("T21").Value & " " & .Range("T22").Value & " " & .Range("T23").Value & " " & .Range("T24").Value ' тема сообщения
    Disclaimer = .Range("P3").Value ' текст сообщения
End With

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next

With OutMail
    .To = adressTo ' получатель сообщения
    .CC = adressCC ' получатели копии сообщения
    .BCC = ""
    .Subject = theme ' тема сообщения
    .HTMLBody = "<p style=font-size:11pt;font-family:Calibri;>" & Disclaimer & _
    RangetoHTML(rng) & vbCrLf & "<p style=font-size:11pt;font-family:Calibri;></a>"
    .Display

End With

Set OutMail = Nothing
Set OutApp = Nothing
sh.AutoFilterMode = False
ThisWorkbook.Save


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

End Sub