Windows("407 408").Activate
    ActiveSheet.ListObjects("Таблица1").Range.AutoFilter Field:=1, Criteria1:= _
    Array("40802810", "40807810", "40701810", "40702810"), Operator:=xlFilterValues
    Windows("407 408").Activate

Sub Макрос2()
'
Workbooks.Open Filename:="C:\Users\m.bolotov\Desktop\Макрос позиции\407 408.xlsx"
        
Windows("407 408.xlsx").Activate
    Columns("L:L").Select
    Selection.NumberFormat = "0"
    Selection.ColumnWidth = 20
    
Selection.TextToColumns Destination:=Range("Таблица1[[#Headers],[ACCT_NO]]") _
        , DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False _
        , Space:=False, Other:=False, FieldInfo:=Array(1, 2), _
        TrailingMinusNumbers:=True
       
        
Windows("407 408").Activate
        Columns("N:N").Select
        Selection.Delete Shift:=xlToLeft
        Columns("A:K").Select
        Selection.Delete Shift:=xlToLeft
    
Windows("407 408").Activate
    ActiveSheet.ListObjects("Таблица1").Range.AutoFilter Field:=1, Criteria1:= _
    Array("40802810", "40807810", "40701810", "40702810"), Operator:=xlFilterValues
    Windows("407 408").Activate
        
End Sub

Sub Макрос20()
'
Workbooks.Open Filename:="C:\Users\m.bolotov\Desktop\Макрос позиции\407 408.xlsx"
        
Windows("407 408.xlsx").Activate
    Columns("L:L").Select
    Selection.NumberFormat = "0"
    Selection.ColumnWidth = 20
    
Selection.TextToColumns Destination:=Range("Таблица1[[#Headers],[ACCT_NO]]") _
        , DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False _
        , Space:=False, Other:=False, FieldInfo:=Array(1, 2), _
        TrailingMinusNumbers:=True
     
        
Windows("407 408").Activate
        Columns("N:N").Select
        Selection.Delete Shift:=xlToLeft
        Columns("A:K").Select
        Selection.Delete Shift:=xlToLeft
    
Windows("407 408").Activate
    ActiveSheet.ListObjects("Таблица1").Range.AutoFilter Field:=1, Criteria1:="=40817978*" _
        , Operator:=xlOr, Criteria2:="=40820978*", Operator:=xlAnd
    Windows("407 408").Activate
       
End Sub

Sub Макрос2()
'
Workbooks.OpenXML Filename:= _
    "C:\Users\m.bolotov\Desktop\Макрос позиции\MGC_AC_OSTR_A_BIP (15).xml", _
    LoadOption:=xlXmlLoadImportToList
Columns("L:L").Select
    Selection.NumberFormat = "0"
    Selection.ColumnWidth = 20
ActiveSheet.ListObjects("Таблица1").Range.AutoFilter Field:=12, Criteria1:= _
    Array("40802810"), Operator:=xlFilterValues
End Sub

Sub Лист2()
'Открываем файл с которого нужно скопировать данные
Workbooks.Open Filename:="C:\Users\m.bolotov\Desktop\Макрос портфеля\ActiveRateAverage.xls"
'Скопировать нужный диапазон в открывшейся книге на листе 1
Workbooks("ActiveRateAverage.xls").Worksheets("ActiveRateAverage").Range("F2:F500").Copy
'Активируем нужную нам книгу
Workbooks("ВПР.xlsm").Activate
'Выделяем и вставляем скопированные данные в ячейку А1
ActiveWorkbook.Worksheets("Лист2").Range("A3").Select
ActiveSheet.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Закрываем книгу откуда мы скопировали данные
Workbooks("ActiveRateAverage.xls").Close
End Sub

ActiveSheet.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Sub Лист2()
'Открываем файл с которого нужно скопировать данные
Workbooks.Open Filename:="C:\Users\m.bolotov\Desktop\Макрос портфеля\ActiveRateAverage.xls"
'Скопировать нужный диапазон в открывшейся книге на листе 1
Workbooks("ActiveRateAverage.xls").Worksheets("ActiveRateAverage").Range("F2:F500").Copy
'Активируем нужную нам книгу
Workbooks("ВПР.xlsm").Activate
'Выделяем и вставляем скопированные данные в ячейку А1
ActiveWorkbook.Worksheets("Лист2").Range("A3").Select
ActiveSheet.Paste
'Закрываем книгу откуда мы скопировали данные
Workbooks("ActiveRateAverage.xls").Close
End Sub

ActiveSheet.PasteSpecial Format:="Текст", Link:=False, DisplayAsIcon:= _
        False

фИО = Trim$(.Cells(1).Text) & "" & Trim$(.Cells(2).Text) & "" & Trim$(.Cells(3).Text)

ФИО = Trim$(.Cells(1).Text) & "" & Trim$(.Cells(2).Text) & "" & Trim$(.Cells(3))

Const ИмяФайлаШаблона = "шаблон 1.dot"
Const КоличествоОбрабатываемыхСтолбцов = 20
Const РасширениеСоздаваемыхФайлов = ".doc"

Sub СформироватьДоговоры()
    ПутьШаблона = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаШаблона)
    НоваяПапка = NewFolderName & Application.PathSeparator
    Dim row As Range, pi As New ProgressIndicator
    r = Cells(Rows.Count, "A").End(xlUp).row: rc = r - 2
    If rc < 1 Then MsgBox "Строк для обработки не найдено", vbCritical: Exit Sub

    pi.Show "Формирование договоров": pi.ShowPercents = True: s1 = 10: s2 = 90: p = s1: a = (s2 - s1) / rc
    pi.StartNewAction , s1, "Запуск приложения Microsoft Word"

    ' Dim WA As Word.Application, WD As Word.Document: Set WA = New Word.Application    ' c подключением библиотеки Word
    Dim WA As Object, WD As Object: Set WA = CreateObject("Word.Application")    ' без подключения библиотеки Word

    For Each row In ActiveSheet.Rows("3:" & r)
        With row
            ФИО = Trim$(.Cells(1)) & "" & Trim$(.Cells(2)) & "" & Trim$(.Cells(3))
            Filename = НоваяПапка & ФИО & РасширениеСоздаваемыхФайлов

            pi.StartNewAction p, p + a / 3, "Создание нового файла на основании шаблона", ФИО
            Set WD = WA.Documents.Add(ПутьШаблона): DoEvents

            pi.StartNewAction p + a / 3, p + a * 2 / 3, "Замена данных ...", ФИО
            For i = 1 To КоличествоОбрабатываемыхСтолбцов
                FindText = Cells(1, i): ReplaceText = Trim$(.Cells(i).Text)

                ' так почему-то заменяет не всё (не затрагивает таблицу)
                'WA.Selection.Find.Execute FindText, , , , , , , wdFindContinue, False, ReplaceText, True

                pi.line3 = "Заменяется поле " & FindText
                With WD.Range.Find
                    .Text = FindText
                    .Replacement.Text = ReplaceText
                    .Forward = True
                    .Wrap = 1
                    .Format = False: .MatchCase = False
                    .MatchWholeWord = False
                    .MatchWildcards = False
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                    .Execute Replace:=2
                End With
                DoEvents
            Next i
            pi.StartNewAction p + a * 2 / 3, p + a, "Сохранение файла ...", ФИО, " "
            WD.SaveAs Filename: WD.Close False: DoEvents
            p = p + a
        End With
    Next row

    pi.StartNewAction s2, , "Завершение работы приложения Microsoft Word", " ", " "
    WA.Quit False: pi.Hide
    msg = "Сформировано " & rc & " договоров. Все они находятся в папке" & vbNewLine & НоваяПапка
    MsgBox msg, vbInformation, "Готово"
End Sub

Function NewFolderName() As String
    NewFolderName = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "Распоряжения, сформированные " & Get_Now)
    MkDir NewFolderName
End Function

Function Get_Date() As String: Get_Date = Replace(Replace(DateValue(Now), "/", "-"), ".", "-"): End Function
Function Get_Time() As String: Get_Time = Replace(TimeValue(Now), ":", "-"): End Function
Function Get_Now() As String: Get_Now = Get_Date & " в " & Get_Time: End Function

WD.SaveAs Filename, 7: WD.Close False: DoEvents

WD.SaveAs Filename: WD.Close False: DoEvents

Const ИмяФайлаШаблона = "шаблон.txt"
Const КоличествоОбрабатываемыхСтолбцов = 5
Const РасширениеСоздаваемыхФайлов = ".txt"

Sub СформироватьДоговоры()
    ПутьШаблона = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаШаблона)
    НоваяПапка = NewFolderName & Application.PathSeparator
    Dim row As Range, pi As New ProgressIndicator
    r = Cells(Rows.Count, "A").End(xlUp).row: rc = r - 2
    If rc < 1 Then MsgBox "Строк для обработки не найдено", vbCritical: Exit Sub

    pi.Show "Формирование договоров": pi.ShowPercents = True: s1 = 10: s2 = 90: p = s1: a = (s2 - s1) / rc
    pi.StartNewAction , s1, "Запуск приложения Microsoft Word"

    ' Dim WA As Word.Application, WD As Word.Document: Set WA = New Word.Application    ' c подключением библиотеки Word
    Dim WA As Object, WD As Object: Set WA = CreateObject("Word.Application")    ' без подключения библиотеки Word

    For Each row In ActiveSheet.Rows("3:" & r)
        With row
            ФИО = Trim$(.Cells(1)) & "" & Trim$(.Cells(2)) & "" & Trim$(.Cells(3))
            Filename = НоваяПапка & ФИО & РасширениеСоздаваемыхФайлов

            pi.StartNewAction p, p + a / 3, "Создание нового файла на основании шаблона", ФИО
            Set WD = WA.Documents.Add(ПутьШаблона): DoEvents

            pi.StartNewAction p + a / 3, p + a * 2 / 3, "Замена данных ...", ФИО
            For i = 1 To КоличествоОбрабатываемыхСтолбцов
                FindText = Cells(1, i): ReplaceText = Trim$(.Cells(i).Text)

                ' так почему-то заменяет не всё (не затрагивает таблицу)
                'WA.Selection.Find.Execute FindText, , , , , , , wdFindContinue, False, ReplaceText, True

                pi.line3 = "Заменяется поле " & FindText
                With WD.Range.Find
                    .Text = FindText
                    .Replacement.Text = ReplaceText
                    .Forward = True
                    .Wrap = 1
                    .Format = False: .MatchCase = False
                    .MatchWholeWord = False
                    .MatchWildcards = False
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                    .Execute Replace:=2
                End With
                DoEvents
            Next i
            pi.StartNewAction p + a * 2 / 3, p + a, "Сохранение файла ...", ФИО, " "
            WD.PrintOut
            WD.SaveAs Filename: WD.Close False: DoEvents
            p = p + a
        End With
    Next row

    pi.StartNewAction s2, , "Завершение работы приложения Microsoft Word", " ", " "
    WA.Quit False: pi.Hide
    msg = "Сформировано " & rc & " договоров. Все они находятся в папке" & vbNewLine & НоваяПапка
    MsgBox msg, vbInformation, "Готово"
End Sub

Function NewFolderName() As String
    NewFolderName = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "Распоряжения, сформированные " & Get_Now)
    MkDir NewFolderName
End Function

Function Get_Date() As String: Get_Date = Replace(Replace(DateValue(Now), "/", "-"), ".", "-"): End Function
Function Get_Time() As String: Get_Time = Replace(TimeValue(Now), ":", "-"): End Function
Function Get_Now() As String: Get_Now = Get_Date & " в " & Get_Time: End Function

Const ИмяФайлаШаблона = "шаблон.dot"
Const КоличествоОбрабатываемыхСтолбцов = 5
Const РасширениеСоздаваемыхФайлов = ".doc"

Sub СформироватьДоговоры()
    ПутьШаблона = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаШаблона)
    НоваяПапка = NewFolderName & Application.PathSeparator
    Dim row As Range, pi As New ProgressIndicator
    r = Cells(Rows.Count, "A").End(xlUp).row: rc = r - 2
    If rc < 1 Then MsgBox "Строк для обработки не найдено", vbCritical: Exit Sub

    pi.Show "Формирование договоров": pi.ShowPercents = True: s1 = 10: s2 = 90: p = s1: a = (s2 - s1) / rc
    pi.StartNewAction , s1, "Запуск приложения Microsoft Word"

    ' Dim WA As Word.Application, WD As Word.Document: Set WA = New Word.Application    ' c подключением библиотеки Word
    Dim WA As Object, WD As Object: Set WA = CreateObject("Word.Application")    ' без подключения библиотеки Word

    For Each row In ActiveSheet.Rows("3:" & r)
        With row
            ФИО = Trim$(.Cells(1)) & "" & Trim$(.Cells(2)) & "" & Trim$(.Cells(3))
            Filename = НоваяПапка & ФИО & РасширениеСоздаваемыхФайлов

            pi.StartNewAction p, p + a / 3, "Создание нового файла на основании шаблона", ФИО
            Set WD = WA.Documents.Add(ПутьШаблона): DoEvents

            pi.StartNewAction p + a / 3, p + a * 2 / 3, "Замена данных ...", ФИО
            For i = 1 To КоличествоОбрабатываемыхСтолбцов
                FindText = Cells(1, i): ReplaceText = Trim$(.Cells(i).Text)

                ' так почему-то заменяет не всё (не затрагивает таблицу)
                'WA.Selection.Find.Execute FindText, , , , , , , wdFindContinue, False, ReplaceText, True

                pi.line3 = "Заменяется поле " & FindText
                With WD.Range.Find
                    .Text = FindText
                    .Replacement.Text = ReplaceText
                    .Forward = True
                    .Wrap = 1
                    .Format = False: .MatchCase = False
                    .MatchWholeWord = False
                    .MatchWildcards = False
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                    .Execute Replace:=2
                End With
                DoEvents
            Next i
            pi.StartNewAction p + a * 2 / 3, p + a, "Сохранение файла ...", ФИО, " "
            WD.SaveAs Filename: WD.Close False: DoEvents
            p = p + a
        End With
    Next row

    pi.StartNewAction s2, , "Завершение работы приложения Microsoft Word", " ", " "
    WA.Quit False: pi.Hide
    msg = "Сформировано " & rc & " договоров. Все они находятся в папке" & vbNewLine & НоваяПапка
    MsgBox msg, vbInformation, "Готово"
End Sub

Function NewFolderName() As String
    NewFolderName = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "Распоряжения, сформированные " & Get_Now)
    MkDir NewFolderName
End Function

Function Get_Date() As String: Get_Date = Replace(Replace(DateValue(Now), "/", "-"), ".", "-"): End Function
Function Get_Time() As String: Get_Time = Replace(TimeValue(Now), ":", "-"): End Function
Function Get_Now() As String: Get_Now = Get_Date & " в " & Get_Time: End Function

Sub Unzip()
    Dim FSO As Object
    Dim oApp As Object
    Dim Fname
    Dim FileNameFolder As Variant
    Dim DefPath As String
    Dim x As Integer

    Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
                                        MultiSelect:=True)
    If TypeName(Fname) = "Boolean" Then
        MsgBox "Не выбрано ни одного файла!"
        Exit Sub
    End If
        'Папка назначения
        DefPath = "C:\test\"    ' Измените на свой путь
        If Right(DefPath, 1) <> "\" Then
            DefPath = DefPath & "\"
        End If
        x = 1
        While x <= UBound(Fname)
        FileNameFolder = DefPath
        
        'Извлеките файлы в папку Destination
        Set oApp = CreateObject("Shell.Application")
        oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname(x)).items
        x = x + 1
        Wend
        
        MsgBox "You find the files here: " & FileNameFolder
                
        On Error Resume Next
        Set FSO = CreateObject("scripting.filesystemobject")
        FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
    
End Sub

Sub Unzip()
    Dim FSO As Object
    Dim oApp As Object
    Dim Fname
    Dim FileNameFolder As Variant
    Dim DefPath As String
    Dim x As Integer

    Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
                                        MultiSelect:=True)
    If TypeName(Fname) = "Boolean" Then
        MsgBox "Не выбрано ни одного файла!"
        Exit Sub
    End If
        'Папка назначения
        DefPath = "C:\test\"    ' Измените на свой путь
        If Right(DefPath, 1) <> "\" Then
            DefPath = DefPath & "\"
        End If
        x = 1
        While x <= UBound(Fname)
        FileNameFolder = DefPath
        
        'Извлеките файлы в папку Destination
        Set oApp = CreateObject("Shell.Application")
        oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items
        
        MsgBox "You find the files here: " & FileNameFolder
        x = x + 1
        Wend
        
        On Error Resume Next
        Set FSO = CreateObject("scripting.filesystemobject")
        FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
    
End Sub

Sub Unzip()
    Dim FSO As Object
    Dim oApp As Object
    Dim Fname As Variant
    Dim FileNameFolder As Variant
    Dim DefPath As String

    Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
                                        MultiSelect:=False)
    If Fname = False Then
        'Do nothing
    Else
        'Destination folder
        DefPath = "C:\test\"    ' Change to your path / variable
        If Right(DefPath, 1) <> "\" Then
            DefPath = DefPath & "\"
        End If

        FileNameFolder = DefPath

        '        'Delete all the files in the folder DefPath first if you want
        '        On Error Resume Next
        '        Kill DefPath & "*.*"
        '        On Error GoTo 0

        'Extract the files into the Destination folder
        Set oApp = CreateObject("Shell.Application")
        oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items

        MsgBox "You find the files here: " & FileNameFolder

        On Error Resume Next
        Set FSO = CreateObject("scripting.filesystemobject")
        FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
    End If
End Sub

Sub Макрос_сборки()
    Dim FilesToOpen
    Dim x As Integer
 
    Application.ScreenUpdating = False  'отключаем обновление экрана для скорости
     
    'вызываем диалог выбора файлов для импорта
    FilesToOpen = Application.GetOpenFilename _
      (FileFilter:="All files (*.*), *.*", _
      MultiSelect:=True, Title:="Files to Merge")
 
    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "Не выбрано ни одного файла!"
        Exit Sub
    End If
     
    'проходим по всем выбранным файлам
    x = 1
    While x <= UBound(FilesToOpen)
        Set importWB = Workbooks.OpenXML(Filename:=FilesToOpen(x), _
        Stylesheets:=Array(1))
        Sheets().Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        importWB.Close savechanges:=False
        x = x + 1
    Wend
 
    Application.ScreenUpdating = True
End Sub

ChDir
"C:\Users\m.bolotov\Desktop\Сборка"

    Workbooks.OpenXML Filename:= _

       
"C:\Users\m.bolotov\Desktop\Сборка\MC04084_EQM13_003_040419_014925553.xml",
_

        Stylesheets:=Array(2)

   
Windows("Макрос сборки - копия.xlsm").Activate