ActiveSheet.UsedRange.AutoFilter Field:=10, Criteria1:=xlFilterThisMonth, Operator:=xlFilterDynamic

Sub NewRows()
Dim i As Long '
Dim x As Range, rngPast As Range

With Worksheets(1).Columns(1)
    For i = 2 To .Cells(.Rows.Count).End(xlUp).Row
    Set x = Worksheets(2).Columns(1).Find(.Cells(i), LookIn:=xlValues, lookat:=xlPart)
    If x Is Nothing Then
    .Cells(i).Copy
    
    Set rngPast = (Worksheets(1).Range("a" & Rows.Count).End(xlUp).Offset(1))
    rngPast.PasteSpecial (xlPasteAll)
    End If
    Next i
End With
End Sub

Sub Send_D()
    Dim objOutlookApp As Object, objMail As Object

    Application.ScreenUpdating = False
        On Error Resume Next 'пробуем подключиться к Outlook, если он уже открыт
        Set objOutlookApp = GetObject(, "Outlook.Application")
        Err.Clear 'Outlook закрыт, очищаем ошибку
        If objOutlookApp Is Nothing Then
    Set objOutlookApp = CreateObject("Outlook.Application")
    End If
    Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
    'если не получилось создать приложение или экземпляр сообщения - выходим
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub

 
    With objMail 'создаем сообщение
        .To = ""
        .CC = ""
        '.BCC = ""
        .Subject = " Weekly PDCA" 
      .HTMLBody = "<p style='font-family:Calibri Light;font-size:13'>" & "Добрый день." & vbNewLine & "Ниже результаты за текущую неделю." & vbCrLf & _
                    "<p style='font-family:Calibri Light;font-size:13'>" & "" & vbNewLine & _
                    "<b><p style='font-family:Calibri Light;font-size:13'>   Files location at NPI Library: <br>" & vbCrLf & _
                    "       -    EE Weekly file  - " & Link1 & " <br>" & _
                    "       -    Inventory Snapshots  - " & Link2 & " <br>" & _
                    "       -    Weekly NPI  - " & Link3 & " <br>" & _
                    "<p style='font-family:Calibri Light;font-size:13'> Whole portfolio s</b>"
        .Display '.Send если необходимо просмотреть сообщение, а не отправлять без просмотра
     End With
     Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub

Private Function SubStr(r As Range, n As Integer, Del As String) As String
Application.Volatile
SubStr = Split(r.Value, Del)(n - 1)
End Function
-----
Sub ПереносЗначений() '
Dim n&
Application.ScreenUpdating = False
Application.EnableEvents = False
Worksheets("Report").Activate
With ActiveSheet
n = .Cells(Rows.Count, 1).End(xlUp).Row + 1 ' строка после последней пустой
.Cells(n, 3).Value = Worksheets("List").Cells(2, 3).Value
.Cells(n, 4).Value = Worksheets("List").Cells(1, 1).Value
.Cells(n, 5).Value = Worksheets("List").Cells(3, 3).Value
.... и др.
Application.EnableEvents = True
End With
End Sub