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, 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

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

adodb.Connection.OpenSchema(adSchemaColumns)

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

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

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

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

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

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

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;)))

=Количество

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

=ЕСЛИОШИБКА(НАИМЕНЬШИЙ(A:A;СТРОКА(A1));"")

=ЕСЛИ(D2<"";СУММЕСЛИ(A:A;D2;B:B);"")

Shell "explorer /select,""" & ThisWorkbook.Path & "\!!! Результат.xlsx""", 1

    Dim i&, j As Variant
    With ActiveSheet.UsedRange
        With Intersect(.Offset(5), .Cells)
            arr = .Value
            For i = LBound(arr, 1) To UBound(arr, 1)
                For Each j In Array(17, 26)
                    Macr = arr(i, j - .Column + 1)
                    If Macr <> "" Then
                        Application.Run Macr
                        Application.Wait Now + #12:00:05 AM#
                    End If
            Next j, i
        End With
    End With

    Dim r As Range, col As Variant
    With ActiveSheet.UsedRange
        With Intersect(.Offset(5), .Cells)
            For Each r In .Rows
                For Each col In Array("Q", "Z")
                    Macr = r.Columns(col).Value
                    If Macr <> "" Then
                        Application.Run Macr
                        Application.Wait Now + #12:00:05 AM#
                    End If
            Next col, r
        End With
    End With

'---------------------------------------------------------------------------------------
' Модуль    : modFilenames
' Автор     : EducatedFool (Игорь)                    Дата: 13.04.2011
' Разработка макросов для Excel, Word, CorelDRAW. Быстро, профессионально, недорого.
' http://excelvba.ru/          ICQ: 5836318           Skype: ExcelVBA.ru
' Реквизиты для оплаты: http://excelvba.ru/payments
'---------------------------------------------------------------------------------------
Option Explicit
Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", _
                             Optional ByVal SearchDeep As Long = 999) As Collection
    ' Получает в качестве параметра путь к папке FolderPath,
    ' маску имени искомых файлов Mask (будут отобраны только файлы с такой маской/расширением)
    ' и глубину поиска SearchDeep в подпапках (если SearchDeep=1, то подпапки не просматриваются).
    ' Возвращает коллекцию, содержащую полные пути найденных файлов
    ' (применяется рекурсивный вызов процедуры GetAllFileNamesUsingFSO)
    Dim fso As Object

    Set FilenamesCollection = New Collection    ' создаём пустую коллекцию
    Set fso = CreateObject("Scripting.FileSystemObject")    ' создаём экземпляр FileSystemObject
    GetAllFileNamesUsingFSO FolderPath, Mask, fso, FilenamesCollection, SearchDeep    ' поиск
    Set fso = Nothing: Application.StatusBar = False    ' очистка строки состояния Excel
End Function

Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef fso, _
                    ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)
    ' перебирает все файлы и подпапки в папке FolderPath, используя объект FSO
    ' перебор папок осуществляется в том случае, если SearchDeep > 1
    ' добавляет пути найденных файлов в коллекцию FileNamesColl
    Dim curfold As Object, fil As Object, sfol As Object
    On Error Resume Next: Set curfold = fso.GetFolder(FolderPath)
    If Not curfold Is Nothing Then    ' если удалось получить доступ к папке

        ' раскомментируйте эту строку для вывода пути к просматриваемой
        ' в текущий момент папке в строку состояния Excel
        Application.StatusBar = "Поиск в папке: " & FolderPath

        For Each fil In curfold.Files    ' перебираем все файлы в папке FolderPath
            If fil.Name Like "*" & Mask And Left(fil.Name, 1) <> "~" Then FileNamesColl.Add fil.Path
        Next
        SearchDeep = SearchDeep - 1    ' уменьшаем глубину поиска в подпапках
        If SearchDeep Then    ' если надо искать глубже
            For Each sfol In curfold.SubFolders    ' ' перебираем все подпапки в папке FolderPath
                GetAllFileNamesUsingFSO sfol.Path, Mask, fso, FileNamesColl, SearchDeep
            Next
        End If
        Set fil = Nothing: Set curfold = Nothing    ' очищаем переменные
    End If
End Function

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
        With .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") 'объект ArrayList, в него будем собирать заголовки столбцов
        Set con = CreateObject("adodb.Connection") 'ADODB подключение, будем его использовать для сбора заголовков столбцов
        
        'пишем в коллекцию пути всех excel книг из выбранной папки
        Set ColFiles = FilenamesCollection(sFolderPath, "*.xls*")

        'перебираем пути файлов в коллекции
        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;"";"
            'перебиреаем значения поля COLUMN_NAME из схемы adSchemaColumns
            For Each sColName In con.OpenSchema(4).getrows(, , 3)
                c = Replace(sColName, "$", "")
                'если значение еще не добавлено в AL, то добавляем
                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 'если номер столбца с искомым заголовком не равен позиции заголовка в AL
                    'перемещаем столбец в нужную позицию
                    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