let
    Источник = Excel.Workbook(File.Contents("C:\Users\damir.ispolov\Desktop\Новая папка\Исполнение ГПЗ.xlsx"), null, true),
    Таблица1_Table = Источник{[Item="Таблица1",Kind="Table"]}[Data],
    #"Измененный тип1" = Table.TransformColumnTypes(Таблица1_Table,{{"Заявка", Int64.Type}, {"Вн. Заказчик", type text}, {"Менеджер", type text}, {"Отдел", type text}, {"Код ТРУ", Int64.Type}, {"Материал", type text}, {"Категория", type text}, {"ЕИ", type text}, {"№ спецификации", type text}, {"№ Конкурса", type text}, {"№ договора SAP (системный)", type text}, {"№ Лота SAP", type text}, {"№ заказа SAP", Int64.Type}, {"№ договора SAP (внешний)", type text}, {"Менеджер_ТРУ", type text}, {"Статус отработки", type text}, {"Этап", type text}, {"Правило закупок (SAP)", type text}, {"Дата заявки", type date}, {"Дата деблокирования логистом", type any}, {"Шифр ИП", type text}, {"Название ИП", type text}, {"Лот 11", type text}, {"Прогноз своевременности", type text}, {"Статус план.", type text}, {"ЦО", type text}, {"Товар/Услуга", type text}, {"БЕ", type text}, {"СЗП/Центр.закуп", type text}, {"Статус конкурса", type text}, {"Пояснение блокировки логистами", type text}, {"Кол-во", type number}, {"Сумма в заявке  (без НДС), KZT", type number}, {"Месяц желаемой поставки", type date}, {"Прогноз поставки", type date}}),
    #"Строки с примененным фильтром" = Table.SelectRows(#"Измененный тип1", each ([Дата деблокирования логистом] = "-"))
in
    #"Строки с примененным фильтром"

Sub Zakup()
Application.ScreenUpdating = False

Set shMain = Sheets("Лист1")
lr = shMain.Cells(Rows.Count, "c").End(xlUp).Row
For i = 2 To lr
    If shMain.Range("c" & i) <> shMain.Range("c" & i - 1) Then
    k = 1
        Set wb = Workbooks.Add(1): Set sh = wb.Sheets(1)
        shMain.Rows(1).Copy
        sh.Range("A1").PasteSpecial xlPasteAll
        wb.SaveAs ThisWorkbook.Path & "\" & shMain.Range("c" & i) & " .xlsx", FileFormat:=xlOpenXMLWorkbook
        k = k + 1
        sh.Rows(k) = shMain.Rows(i).Value
        If shMain.Range("c" & i) <> shMain.Range("c" & i + 1) Then wb.Close True
    Else
        k = k + 1
        sh.Rows(k) = shMain.Rows(i).Value
        If shMain.Range("c" & i) <> shMain.Range("c" & i + 1) Then wb.Close True
    End If

Next
End Sub

Public SelectedDate As String, DefaultDate As StringPublic dt_1 As Date, dt_2 As Date
Option Explicit
Sub GetRates()


Dim sURL As String
Dim objHttp As Object
Dim sHtmlCode As String
Dim varInpDate As Variant
Dim WshShell As Object
Dim RegValue As String
Dim sDay As String, sMonth As String, sYear As String
Dim sDollarRate As String, sEuroRate As String, sYuanRate As String, sPoundRate As String
    'varInpDate = InputBox("Введите дату в формате ДД.ММ.ГГГГ", "Курсы валют", Date)
    Form_SelectDate.Show
    varInpDate = CStr(SelectedDate)
    If varInpDate = "" Then Exit Sub
    varInpDate = CDate(varInpDate)
    sDay = Format(varInpDate, "dd")
    sMonth = Format(varInpDate, "mm")
    sYear = Format(varInpDate, "yyyy")
    sURL = "http://www.nationalbank.kz/rss/get_rates.cfm?fdate=" & _
            sDay & "." & sMonth & "." & sYear & "&switch=kazakh"
    On Error Resume Next
    Set objHttp = CreateObject("MSXML2.XMLHTTP.3.0")
    If Err.Number <> 0 Then
        Err.Clear
        Set objHttp = CreateObject("MSXML2.XMLHTTP")
        If Err.Number <> 0 Then
            Set objHttp = CreateObject("MSXML.XMLHTTPRequest")
        End If
    End If
    If objHttp Is Nothing Then
        MsgBox "Невозможно создать объект для подключения к интернет!", 48, "Ошибка"
        Exit Sub
    End If
    If objHttp Is Nothing Then Exit Sub
    objHttp.Open "GET", sURL, False
    On Error Resume Next
    objHttp.Send
    If Err.Number <> 0 Then
        MsgBox "Отсутствует доступ в интернет!", 48, "Ошибка"
        Exit Sub
    End If
    On Error GoTo 0
    sHtmlCode = objHttp.responseText
    Set objHttp = Nothing
    On Error Resume Next
    sDollarRate = Mid(sHtmlCode, InStr(InStr(1, sHtmlCode, "USD"), sHtmlCode, "</td></tr>") - 7, 7)
    sEuroRate = Mid(sHtmlCode, InStr(InStr(1, sHtmlCode, "EUR"), sHtmlCode, "</td></tr>") - 7, 7)
    sHtmlCode = ""
    '-------------------------------------------------------------------------------
    'считываем значение ключа реестра
    'HKEY_CURRENT_USER\Control Panel\International\\sMonDecimalSep
    'чтобы узнать какой знак является разделителем целой и дробной части
    'указанной в Панель управления - Язык и региональные стандарты -
    'Настройка - Денежная единица - Разделитель целой и дробной части
    Set WshShell = CreateObject("WScript.Shell")
    RegValue = WshShell.RegRead("HKEY_CURRENT_USER\Control Panel\International\\sMonDecimalSep")
    If RegValue = "." Then
        sDollarRate = CSng(Replace(sDollarRate, ",", "."))
        sEuroRate = CSng(Replace(sEuroRate, ",", "."))
    End If
    '-------------------------------------------------------------------------------
    Application.ScreenUpdating = False
    [DollarRng] = ""
    [EuroRng] = ""
    [DateRng] = varInpDate
    [DollarRng] = Replace(sDollarRate, ",", ".")
    [EuroRng] = Replace(sEuroRate, ",", ".")
    ActiveSheet.Hyperlinks.Add Anchor:=Range("LinkRng"), Address:=sURL, _
            ScreenTip:="Перейти на сайт НБ РК", TextToDisplay:="НБ РК"
    Application.ScreenUpdating = True
    MsgBox Format(varInpDate, "DD MMMM YYYY") & Chr(13) & Chr(13) _
            & "Доллар: " & vbTab & sDollarRate & Chr(13) & "Евро: " & vbTab & sEuroRate & Chr(13) _
            & "Отношение: " & Format(sEuroRate / sDollarRate, "0.0000"), 64, "Курсы валют"
End Sub

Public Sub saveAtt(itm As Outlook.MailItem)

Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim sDateMail As String

sDateMail = Format(itm.CreationTime, "hh-mm-ss_dd.mm.yyyy")
saveFolder = "C:\Users\aidyn.khalimbetov\Desktop\сложные ТРУ\"

For Each objAtt In itm.Attachments
  objAtt.SaveAsFile saveFolder & "\" & sDateMail & "_" & objAtt.FileName
  Set objAtt = Nothing
Next objAtt

End Sub

Sub ertert()
Dim fn As String, wsh As Worksheet, wb As Object
Dim r As Range, rr As Range, s As String, ss As String
Application.ScreenUpdating = False
ActiveSheet.Copy Before:=Sheets(1)
Set wsh = ActiveSheet: s = "ВСЕГО": ss = "Контрагент"
With wsh.UsedRange.Columns("B:B")
    Do
     Set r = .Find(s, lookat:=xlWhole)
     If Not r Is Nothing Then
      With .Cells(1, 1).Resize(r.Row)
          Set rr = .Find(ss, lookat:=xlWhole)
          If Not rr Is Nothing Then
           fn = ThisWorkbook.Path & "\" & Replace(rr(1, 2), """", "")& "_" & rr(2, 2) & ".xls"
           Set wb = Workbooks.Add
           .EntireRow.Copy
           wb.Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteAll
           wb.Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
           wb.SaveAs fn, xlNormal: DoEvents: wb.Close
          End If
          .EntireRow.Delete
      End With
     End If
    Loop Until r Is Nothing
End With