Sub Splitter()

 Application.ScreenUpdating = False
 Application.DisplayAlerts = False
 
 Dim h As Integer
 Dim wrksht As Worksheet
 Dim oListObj As ListObject

       For h = 2 To Sheets.Count
       Set wrksht = ActiveWorkbook.Worksheets(h)
       
       Set oListObj = wrksht.ListObjects(1)
 
        For Each cell In Range("ФИО")
        Sheets(wrksht.Name).Select
        FinalCol = Cells(1, Application.Columns.Count).End(xlToLeft).Column
        FinalRow = Cells(Application.Rows.Count, 1).End(xlUp).Row
        
        Range(oListObj.Name).AutoFilter Field:=FinalCol, Criteria1:=cell.Value

        Range(Cells(1, 1), Cells(FinalRow, FinalCol)).SpecialCells(xlCellTypeVisible).Copy
        ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)
        ActiveSheet.Paste
        ActiveSheet.Name = cell.Value & "_" & Cells(2, FinalCol - 1).Value
        ActiveSheet.UsedRange.Columns.AutoFit
        Next cell
        Next

 Application.ScreenUpdating = False
 Application.DisplayAlerts = False
End Sub

Source = Folder.Files("D:\S\Проверка")  

Sub CreateNewZip(sPath As String)
    If Dir(sPath) <> "" Then Kill sPath
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub


Sub расслитовка()
Dim s As Worksheet
Dim wb As Workbook
Dim pQuery As WorkbookQuery
Dim aw As Window
Set wb = ActiveWorkbook
Set aw = ActiveWindow
For Each s In aw.SelectedSheets
Set tempwindow = aw.NewWindow
Application.ScreenUpdating = False
s.Copy
For Each pQuery In ActiveWorkbook.Queries
        pQuery.Delete
Next
tempwindow.Close
Application.DisplayAlerts = False
Dim full_path As String
Dim folder_path As String
folder_path = wb.Path & "\" & "База региона " & s.Name & " " & Date & ".zip"
full_path = wb.Path & "\" & "База региона " & s.Name & " " & Date & ".xlsx"
ActiveWorkbook.SaveAs full_path


Call ZIPOneFile(folder_path, full_path)
ActiveWorkbook.Close


Application.DisplayAlerts = True
Next
Application.ScreenUpdating = True
End Sub


 
Function ZIPOneFile(sZIPFileName As String, sFileToZIP As String)
    Dim objShell As Object
    Dim lcnt As Long
 
    Set objShell = CreateObject("Shell.Application")
    'создаем пустой ZIP-архив, если его еще нет
    If Dir(sZIPFileName, 16) = "" Then
        CreateNewZip (sZIPFileName)
    End If
    lcnt = objShell.Namespace((sZIPFileName)).Items.Count
    'помещаем файлы из папки в архив
    objShell.Namespace((sZIPFileName)).CopyHere CStr(sFileToZIP)
    'дожидаемся окончания архивации
    Do Until objShell.Namespace((sZIPFileName)).Items.Count = lcnt + 1
        DoEvents
    Loop
End Function

= Table.SelectRows(#"Измененный тип", each [Дата окончания контракта] > #date(2020, 1, 16))

Sub primer()
Dim s As Worksheet
Dim iPath As String

  iPath = ThisWorkbook.Path
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
      Dim AW As Window
    Set AW = ActiveWindow
    For Each s In AW.SelectedSheets
        Set TempWindow = AW.NewWindow
        s.Copy
     ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
     ActiveWorkbook.SaveAs iPath & "\" & Range("B3") & Range("B2") & ActiveSheet.Name & ".xls", FileFormat:=56
     ActiveWorkbook.Close
      TempWindow.Close
     Next
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

Sub RandW()
Dim wb As Workbook
Dim s As Worksheet
Dim AW As Window
Set wb = ActiveWorkbook
Set AW = ActiveWindow
Application.DisplayAlerts = False
'преобразование формул в значения на текущем листе
  ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
 On Error Resume Next
 
  For Each s In Sheets
    If Not s Is ActiveSheet Then s.Visible = xlSheetVisible: s.Delete
  Next
 ' Application.Quit
ActiveWorkbook.SaveCopyAs wb.Path & "\" & Range("B1") & Range("B2") & ActiveSheet.Name & ".xls"

  Application.DisplayAlerts = True
End Sub

Option Explicit
 
Sub Send_Mail()
    Dim objOutlookApp As Object, objMail As Object
    Dim sTo As String, sSubject As String, sBody As String, sAttachment As String
    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
    objOutlookApp.Session.Logon
    Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
    'если не получилось создать приложение или экземпляр сообщения - выходим
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
 
    sTo = "AddressTo@mail.ru"    'Кому(можно заменить значением из ячейки - sTo = Range("A1").Value)
    sSubject = Range("AF4")    'Тема письма(можно заменить значением из ячейки - sSubject = Range("A2").Value)
    sBody = "Странно, что не отображается " & Range("B9") & "\Microsoft\Signatures\"
Dim sTblBody As String
sTblBody = ConvertRngToHTM(Selection)
     'Текст письма(можно заменить значением из ячейки - sBody = Range("A3").Value)
    sAttachment = "C:\Temp\Книга1.xls"    'Вложение(полный путь к файлу. Можно заменить значением из ячейки - sAttachment = Range("A4").Value)
 
    'создаем сообщение
    With objMail
        .To = sTo 'адрес получателя
        .CC = "" 'адрес для копии
        .BCC = "" 'адрес для скрытой копии
        .Subject = sSubject 'тема сообщения
        .Body = sBody  'текст сообщения
        '.HTMLBody = sBody 'если необходим форматированные текст сообщения(различные шрифты, цвет шрифта и т.п.)
        .Attachments.Add sAttachment 'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName
        '.Send 'Display, если необходимо просмотреть сообщение, а не отправлять без просмотра
        .Display
    End With
 
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub
Function ConvertRngToHTM(rng As Range)
    Dim fso As Object, ts As Object
    Dim sF As String, resHTM As String
    Dim wbTmp As Workbook
 
    sF = Environ("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    'переносим указанный диапазон в новую книгу
    rng.Copy
    Set wbTmp = Workbooks.Add(1)
    With wbTmp.Sheets(1)
        'вставляем только ширину столбцов, значения и форматы
        .Cells(1).PasteSpecial xlPasteColumnWidths
        .Cells(1).PasteSpecial xlPasteValues
        .Cells(1).PasteSpecial xlPasteFormats
        .Cells(1).Select
        Application.CutCopyMode = False
        'удаляем все объекты(фигуры, рисунки и пр.)
        '------------------------------------------
        'если рисунки и объекты нужны - удалить этот блок
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
        '------------------------------------------
    End With
    'сохраняем книгу как Веб-страницу(чтобы содержимое конвертировать в HTML-код)
    With wbTmp.PublishObjects.Add( _
         SourceType:=xlSourceRange, Filename:=sF, _
         Sheet:=wbTmp.Sheets(1).Name, Source:=wbTmp.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    'открываем созданный файл как текстовый и считываем содержимое
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sF).OpenAsTextStream(1, -2)
    resHTM = ts.ReadAll
    ts.Close
    'выравниваем таблицу по левому краю(если надо оставить по центру - удалить эту строку)
    ConvertRngToHTM = Replace(resHTM, "align=center x:publishsource=", "align=left x:publishsource=")
    'закрываем временную книгу и удаляем
    wbTmp.Close False
    Kill sF
    'очищаем объектные переменные
    Set ts = Nothing: Set fso = Nothing
    Set wbTmp = Nothing
End Function

ActiveWorkbook.Queries("Тест").Delete