objXls5.Sheets("Реестр").Range("A6:BE" & llastr).SpecialCells(12).Copy
objXls6.Sheets("Форма").Paste objXls6.Sheets("Форма").Range("B5")

Sub Реестр()
    SourceFolder = "\\lan\Архив\"
    Set fso = CreateObject("scripting.filesystemobject")
    Set curfold = fso.GetFolder(SourceFolder)
    
    If Not curfold Is Nothing Then
        For Each sfol_1 In curfold.SubFolders
            If sfol_1.Name Like "*Линия*" Then
                For Each sfol_2 In sfol_1.SubFolders
                    If sfol_2.Name Like "L*" Then
                        For Each sfol_3 In sfol_2.SubFolders
                             If sfol_3.Name Like "*-D-*" Then
                                 For Each sfol_4 In sfol_3.SubFolders
                                     If sfol_4.Name Like "*утвержден*" Then
                                         For Each fil In sfol_4.Files
                                            If fil.Name Like "*-D-*" Then
                                                
                                                'добавление информации в реестр на основе найденного файла
                                                
                                             End If
                                         Next
                                     End If
                                 Next
                             End If
                        Next
                    End If
                Next
            End If
        Next
    End If
    Set fil = Nothing: Set curfold = Nothing: Set fso = Nothing

End Sub

objXls5.Sheets("Реестр").Range("W6:X" & llastr).SpecialCells(12).Copy

objXls6.Sheets("Форма").Paste objXls6.Sheets("Форма").Range("H" & llastr2)

Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)

Sleep (400)

llastr = objXls.Sheets("Реестр").Cells(objXls.Sheets("Реестр").Rows.Count, 1).End(-4162).Row

    Dim objXls As Object
    Set objXls = CreateObject("Excel.Application")
 
    objXls.Workbooks.Open "D:\ForMacros\123.xlsx"
    objXls.Application.Visible = True
 
    objXls.Sheets("Лист").Cells(10, 10).Value = "123"
 
    objXls.ActiveWorkbook.Save
    objXls.Workbooks.Close
    Set objXls = Nothing

Sub поиск_писем()

    Dim objFolder As Outlook.MAPIFolder
    Dim filteredItems As Outlook.Items
    Dim itm As Object
    Dim strFilter As String
    
    адрес_новой_папки = "D:\Users\aie\Desktop\123\"
    запрос = "0198"
    
    Set objFolder = Outlook.Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox) 'olFolderInbox папка Входящие

    strFilter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%" & запрос & "%'"
    
    Set filteredItems = objFolder.Items.Restrict(strFilter)
    
    If filteredItems.Count = 0 Then
        MsgBox "Поиск писем результатов не дал"
    Else
        filteredItems(filteredItems.Count).SaveAs адрес_новой_папки & запрос & ".msg"
    End If

End Sub

Sub Ответить_всем_с_вложениями()
    от_кого = Application.ActiveExplorer.Selection(1).Sender
    кому = Application.ActiveExplorer.Selection(1).To
    копия = Application.ActiveExplorer.Selection(1).CC
    от_кого_кому = от_кого + "; " + кому + ";"
    от_кого_кому = Replace(от_кого_кому, "Иванов Иван Иванович", "", 1, 1)
    Dim Item As MailItem
    Set Item = Application.ActiveExplorer.Selection(1).Forward
    Item.To = от_кого_кому
    Item.CC = копия + ";"
    Item.Display
End Sub