aa    =ПОЛУЧИТЬ.ЯЧЕЙКУ(66;C2)

bb    =ПОЛУЧИТЬ.РАБОЧУЮ.КНИГУ(4;aa)

cc    =ИНДЕКС(ПОЛУЧИТЬ.РАБОЧУЮ.КНИГУ(1;aa);Ч(ИНДЕКС(СТОЛБЕЦ($B$1:ИНДЕКС($1:$1;bb));)))

dd    =ПОЛУЧИТЬ.ДОКУМЕНТ(9;Т(ИНДЕКС(cc;0)))

ee    =ПОЛУЧИТЬ.ДОКУМЕНТ(10;Т(ИНДЕКС(cc;0)))

ff    =ПОЛУЧИТЬ.ДОКУМЕНТ(11;Т(ИНДЕКС(cc;0)))

gg    =ЕСЛИ({1:1:0};СЖПРОБЕЛЫ(ПСТР(ПОДСТАВИТЬ(ЛЕВБ($B2;ПОИСК(" ";$B2)-1);"/";ПОВТОР(" ";99));{1:99};99)&ПРАВБ($B2;ДЛСТР($B2)+1-ПОИСК(" ";$B2)));ЕСЛИОШИБКА(Т(ПОИСК("/";$B2))&$B2;))

hh    =ИНДЕКС(ОТБР((СТРОКА(C$1:ИНДЕКС(C:C;МАКС(ee-dd+1)*(bb-1)))-1)/МАКС(ee-dd+1))+1;)

ii    =МИН(dd)+ОСТАТ(СТРОКА(C$1:ИНДЕКС(C:C;МАКС(ee-dd+1)*(bb-1)))-1;МАКС(ee-dd+1))

Количество    =СУММ(СЧЁТЕСЛИ(ДВССЫЛ("'"&cc&"'!R"&МИН(dd)&"C"&CC&":R"&МАКС(ee)&"C"&CC;);gg))

ПоследняяДата    =МАКС((Т(ДВССЫЛ("'"&ИНДЕКС(cc;Ч(hh))&"'!R"&ii&"C"&ИНДЕКС(CC;Ч(hh));))=ТРАНСП(gg))*Ч(ДВССЫЛ("'"&ИНДЕКС(cc;Ч(hh))&"'!R"&ii&"C"&ИНДЕКС(CC;Ч(hh))+1;)))

=Количество

=ПоследняяДата

For Each ar In ['[Карточка учета.xlsm]ОСАГО'!D:D].SpecialCells(2, 1).Areas

Option Explicit
Sub Auto_open()
    Dim wb As Workbook, bClosed As Boolean, ar As Range, c As Range, dtRazn%, s$, msg$
    On Error Resume Next
    Set wb = Workbooks("Карточка учета.xlsm")
    On Error GoTo 0
    If wb Is Nothing Then
        Application.ScreenUpdating = False
        Set wb = Workbooks.Open("C:\Учет страховых полисов\Карточка учета.xlsm")
        wb.Windows(1).Visible = 0
        Application.ScreenUpdating = True
        bClosed = True
    End If
    
    For Each ar In ['[Карточка учета.xlsm]ОСАГО'!D:D].SpecialCells(2, 1).Areas
        For Each c In ar.Cells
            dtRazn = c - Date
            s = ""
            Select Case dtRazn
                Case Is < 0: s = "На " & Abs(dtRazn) & "дн. просрочен "
                Case 0: s = "Сегодня заканчивается "
                Case Is <= 5: s = "Через " & dtRazn & " дн. заканчивается "
            End Select
            If s <> "" Then msg = msg & IIf(msg <> "", vbCrLf, "") & s & _
                "страховой полис ОСАГО на автомобиль " & c.Offset(, -2) & _
                " регистрационный номер " & c.Offset(, -3)
        Next
    Next
    If msg <> "" Then MsgBox msg: Debug.Print msg
    If bClosed Then wb.Close False
End Sub

sh1.Chart.ChartArea.Format.ThreeD.RotationX = (360 + sb_Hor) Mod 360

Sub find_()
    Dim r As Range
    With GetObject(ThisWorkbook.Path & "\3259948.xls")
        Set r = .Sheets("Лист3").Cells.Find([E11], , , xlPart, , , False, , False)
        [F10:F11].ClearContents
        If r Is Nothing Then
            Exit Sub
        Else
            [F10] = r.Address(, , , 1)
            [F11] = r.Value
        End If
        .Close False
    End With
End Sub
Sub rewrite()
    Dim r As Range
    With Application
        .ScreenUpdating = 0: .EnableEvents = 0: .DisplayAlerts = 0
        With GetObject(ThisWorkbook.Path & "\3259948.xls")
            Set r = .Sheets("Лист3").Cells.Find([E11], , , xlPart, , , False, , False)
            If r Is Nothing Then
                Exit Sub
            Else
                Range([F10]) = [F11]
            End If
            .Windows(1).Visible = True
            .Close True
        End With
        .ScreenUpdating = 1: .EnableEvents = 1: .DisplayAlerts = 1
    End With
End Sub

Option Explicit
Sub test()
          Dim sInPath$, sOutPath$, oFSO As Object, sUser$, sPass$, sFolder As Variant
10    sUser = "ИмяПользователя": sPass = "Пароль" 'нужно ввести учетные данные на обменнике
20    On Error GoTo ErrHandler
30    With Application.FileDialog(4)
40        .AllowMultiSelect = False
50        .InitialFileName = "\\10.**.***.*\папка\подпапка\"
60        .Title = "Выберите папку с файлами"
70        GoSub sel
80        sInPath = .SelectedItems(1)
90        .InitialFileName = "F:\PQ\Копирование между папками\Куда\"
100       .Title = "Выберите папку назначения"
110 sel:  If .Show = False Then
120           If MsgBox("Ничего не выбрано. Повторить?", vbYesNo) = vbYes Then
130               Resume sel
140           Else
150               Exit Sub
160           End If
170       End If
180       On Error Resume Next
190       Return
200       On Error GoTo ErrHandler
210   End With

220   With CreateObject("WScript.Network")
230       For Each sFolder In Array(sInPath, sOutPath)
240           If Left(sFolder, 2) = "\\" Then .MapNetworkDrive "", sFolder, False, sUser, sPass
250       Next

260       Set oFSO = CreateObject("scripting.filesystemobject")
270       CopyRecursive oFSO, sInPath, sOutPath, "*.xls*"
280       Set oFSO = Nothing

290       For Each sFolder In Array(sInPath, sOutPath)
300           If Left(sFolder, 2) = "\\" Then .RemoveNetworkDrive sFolder, True, False
310       Next
320   End With
330   Exit Sub
ErrHandler:
340   MsgBox "Произошла ошибка " & Err.Number & "(" & Err.Description & _
          ") в модуле " & Application.VBE.ActiveCodePane.codemodule.Name & _
          " в процедуре test() на строке " & Erl
End Sub
Private Sub CopyRecursive(ByRef oFSO As Object, sCopyFrom$, sCopyTo$, sMask$)
          Dim oFile As Object, oFolder As Object
10    On Error GoTo ErrHandler
20    Set oFolder = oFSO.GetFolder(sCopyFrom)
30    For Each oFile In oFolder.Files
40        If oFile.Name Like "*+*.xls*" Then oFile.Copy sCopyTo & "\" & oFile.Name
50    Next
60    For Each oFolder In oFolder.SubFolders
70        CopyRecursive oFSO, oFolder.Path, sCopyTo, sMask
80    Next
90    Set oFile = Nothing
100   Set oFolder = Nothing
110   Exit Sub
ErrHandler:
120   MsgBox "Произошла ошибка " & Err.Number & "(" & Err.Description & _
          ") в модуле " & Application.VBE.ActiveCodePane.codemodule.Name & _
          " в процедуре CopyRecursive() на строке " & Erl
End Sub

Option Explicit
Sub AdjustColmns()
    Dim con As Object, ColFiles As Collection, AL As Object
    Dim wb As Workbook, sh As Worksheet, r As Range
    Dim sFilePath As Variant, sColName As Variant
    Dim sFolderPath$, c$, ver$, i&, calc&, b As Boolean
    
    With Application.FileDialog(4)
        .AllowMultiSelect = False
        .InitialFileName = CreateObject("Shell.Application").Namespace(5).self.Path & "\"
        .Title = "Выберите папку с файлами"
sel:    If .Show = False Then
            If MsgBox("Ничего не выбрано. Повторить?", vbYesNo) = vbYes Then
                GoTo sel
            Else
                Exit Sub
            End If
        End If
        sFolderPath = .SelectedItems(1) & "\"
    End With
    
    Set AL = CreateObject("system.collections.arraylist")
    Set con = CreateObject("adodb.Connection")
    Set ColFiles = FilenamesCollection(sFolderPath, "*.xls*")
    With Application
        For Each sFilePath In ColFiles
            On Error Resume Next
            .Workbooks(Replace(sFilePath, sFolderPath, "")).Save
            On Error GoTo 0
            Select Case Right(sFilePath, 1)
                Case "s": ver = "8.0"
                Case "x": ver = "12.0 xml"
                Case "m": ver = "12.0 macro"
                Case "b": ver = "12.0"
            End Select
            con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
                sFilePath & ";Mode=Read;Extended Properties=""excel " & ver & ";HDR=YES;IMEX=1;"";"
            For Each sColName In con.OpenSchema(4).getrows(, , 3)
                c = Replace(sColName, "$", "")
                If Not AL.contains(c) Then AL.Add c
            Next
            con.Close
        Next
        AL.Sort
        .ScreenUpdating = 0: .EnableEvents = 0: calc = .Calculation: .Calculation = xlCalculationManual
        For Each sFilePath In ColFiles
            On Error Resume Next
            Set wb = .Workbooks(Replace(sFilePath, sFolderPath, ""))
            On Error GoTo 0
            If wb Is Nothing Then
                Set wb = .Workbooks.Open(sFilePath)
            Else
                b = True
            End If
            With wb
                For Each sh In .Sheets
                    i = 1
                    For Each sColName In AL
                        With sh.Rows(1)
                            Set r = .Find(sColName, , , xlWhole, , , False, , False)
                            If r Is Nothing Then
                    .End(xlToRight).Offset(, 1) = sColName
                    Set r = .End(xlToRight)
                            End If
                            If r.Column <> i Then
                    r.EntireColumn.Cut
                    .Columns(i).Insert Shift:=xlToRight
                            End If
                            i = i + 1
                        End With
                Next sColName, sh
                If Not b Then .Close True
            End With
            Set wb = Nothing
        Next
        .ScreenUpdating = 1: .EnableEvents = 1: .Calculation = calc
    End With
    Set AL = Nothing: Set con = Nothing: Set r = Nothing: Set ColFiles = Nothing
End Sub

adodb.Connection.OpenSchema(adSchemaColumns)

Public Sub creategyperlinks(ByVal sheetname As String, ByVal colname2 As String, ByVal colname As String, ByVal startrow As Integer, ByVal path As String)
    Dim sMask As Variant, sFile As Variant, c As Range, Addr$      'объявление переменных
    Dim iMaxRowCount1 As Integer
    
    iMaxRowCount1 = getrowCounts(colname2, startrow)
    
     For Each sMask In Array("*.pdf", "*.7z")
        For Each sFile In FilenamesCollection(path, sMask, 5)
            With Sheets(sheetname).Range(colname & startrow & ":" & colname & iMaxRowCount1)
                sName = Mid(sFile, InStrRev(sFile, "\") + 1, Len(sFile))
                Set c = Range.Find(Mid(sName, 1, InStrRev(sName, ".") - 1), , xlValues, xlWhole, , , False, , False)
                If Not c Is Nothing Then
                    Addr = c.Address
                    Do
                        If c.Hyperlinks.Count = 0 Then
                            c.Hyperlinks.Add c, sFile, , , c.Text
                        End If
                        Set r = .FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> Addr
                End If
            End With
        Next sFile
    Next sMask
End Sub

Option Explicit
Sub test()
    Dim sInPath$, sOutPath$, oFSO As Object, sUser$, sPass$
    
    sUser = "ИмяПользователя": sPass = "Пароль" 'нужно ввести учетные данные на обменнике
    sInPath = "\\10.**.***.*\папка\подпапка"
    sOutPath = "F:\PQ\Копирование между папками\Куда"
    
    With CreateObject("WScript.Network")
        .MapNetworkDrive "", sInPath, False, sUser, sPass
        
        Set oFSO = CreateObject("scripting.filesystemobject")
        CopyRecursive oFSO, sInPath, sOutPath, "*.xls*"
        Set oFSO = Nothing
        
        .RemoveNetworkDrive sInPath, True, False
    End With
    
End Sub
Private Sub CopyRecursive(ByRef oFSO As Object, sCopyFrom$, sCopyTo$, sMask$)
    Dim oFile As Object, oFolder As Object
    Set oFolder = oFSO.GetFolder(sCopyFrom)
    For Each oFile In oFolder.Files
        If oFile.Name Like "*+*.xls*" Then oFile.Copy sCopyTo & "\" & oFile.Name
    Next
    For Each oFolder In oFolder.SubFolders
        CopyRecursive oFSO, oFolder.Path, sCopyTo, sMask
    Next
    Set oFile = Nothing
    Set oFolder = Nothing
End Sub

    Dim var0 As String: var0 = "C:\........."
    Dim s As String
    With New ADODB.Stream
        .Type = 2: .Mode = 3: .Charset = "utf-8": .LineSeparator = -1:
        .Open: .LoadFromFile var0: s = .ReadText(-2): .Close
        .Open: .WriteText s: .SaveToFile var0, 2: .Close
    End With

Option Explicit
Sub test()
    Dim sInPath$, sOutPath$, oFSO As Object
    
    sInPath = "C:\Users\Мвидео\Desktop\Откуда"
    sOutPath = "C:\Users\Мвидео\Desktop\Куда"
    
    Set oFSO = CreateObject("scripting.filesystemobject")
    
    CopyRecursive oFSO, sInPath, sOutPath, "*.xls*"
        
    Set oFSO = Nothing
End Sub
Private Sub CopyRecursive(ByRef oFSO As Object, sCopyFrom$, sCopyTo$, sMask$)
    Dim oFile As Object, oFolder As Object
    Set oFolder = oFSO.GetFolder(sCopyFrom)
    For Each oFile In oFolder.Files
        If oFile.Name Like "*+*.xls*" Then oFile.Copy sCopyTo & "\" & oFile.Name
    Next
    For Each oFolder In oFolder.SubFolders
        CopyRecursive oFSO, oFolder.Path, sCopyTo, sMask
    Next
    Set oFile = Nothing
    Set oFolder = Nothing
End Sub

For Each iFile In Folder.Files

.Cells(LR + 1, 6)=Application.WorksheetFunction.VLookup("Итого*",[реестр!$B$3:$I$99],4,0)