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)

If iFile.Name Like "*+*.xls*" Then iFile.Copy "C:\Users\Мвидео\Desktop\Куда" & "\" & iFile.Name

=ЕСЛИОШИБКА(ЕСЛИ(СТРОКА()=3;ВЫБОР(ПРОСМОТР(СТОЛБЕЦ();МУМНОЖ(ЕСЛИ({1:2:3}>={1;2;3};$A$1:$C$1*{0;1;1}+{0;1;0};);{1:1:1});{1;2;3});ИНДЕКС(Table;$C$1;СТОЛБЕЦ()-ПРОСМОТР(СТОЛБЕЦ();МУМНОЖ(ЕСЛИ({1:2:3}>={1;2;3};$A$1:$C$1*{0;1;1}+{0;1;0};);{1:1:1}))+1-1)&"";ИНДЕКС($E$1:ИНДЕКС($1:$1;$C$1+4);СТОЛБЕЦ()-ПРОСМОТР(СТОЛБЕЦ();МУМНОЖ(ЕСЛИ({1:2:3}>={1;2;3};$A$1:$C$1*{0;1;1}+{0;1;0};);{1:1:1}))+1)&"";ЕСЛИ(СТОЛБЕЦ()-ПРОСМОТР(СТОЛБЕЦ();МУМНОЖ(ЕСЛИ({1:2:3}>={1;2;3};$A$1:$C$1*{0;1;1}+{0;1;0};);{1:1:1}))+1>$D$1;"";ЕСЛИ($D$1>1;ЕСЛИОШИБКА(ЕСЛИ(ИНДЕКС(ИНДЕКС(Table;1;$B$1+1):ИНДЕКС(Table;$C$1;ЧИСЛСТОЛБ(Table));$C$1;1)=ИНДЕКС(ИНДЕКС(Table;1;$B$1+1):ИНДЕКС(Table;$C$1;ЧИСЛСТОЛБ(Table));$C$1;$D$1+1);ИНДЕКС(ИНДЕКС(Table;1;$B$1+1):ИНДЕКС(Table;$C$1;ЧИСЛСТОЛБ(Table));$C$1;ОСТАТ(СТОЛБЕЦ()-ПРОСМОТР(СТОЛБЕЦ();МУМНОЖ(ЕСЛИ({1:2:3}>={1;2;3};$A$1:$C$1*{0;1;1}+{0;1;0};);{1:1:1}))+1-1;$D$1)+1);СТОЛБЕЦ()-ПРОСМОТР(СТОЛБЕЦ();МУМНОЖ(ЕСЛИ({1:2:3}>={1;2;3};$A$1:$C$1*{0;1;1}+{0;1;0};);{1:1:1}))+1);СТОЛБЕЦ()-ПРОСМОТР(СТОЛБЕЦ();МУМНОЖ(ЕСЛИ({1:2:3}>={1;2;3};$A$1:$C$1*{0;1;1}+{0;1;0};);{1:1:1}))+1);ЕСЛИ(СТОЛБЕЦ()-ПРОСМОТР(СТОЛБЕЦ();МУМНОЖ(ЕСЛИ({1:2:3}>={1;2;3};$A$1:$C$1*{0;1;1}+{0;1;0};);{1:1:1}))+1-1;"";"Значение")))&"");ВЫБОР(ПРОСМОТР(СТОЛБЕЦ();МУМНОЖ(ЕСЛИ({1:2:3}>={1;2;3};$A$1:$C$1*{0;1;1}+{0;1;0};);{1:1:1});{1;2;3});ИНДЕКС(ИНДЕКС(Table;$C$1+1;1):ИНДЕКС(Table;ЧСТРОК(Table);$B$1);ОТБР((СТРОКА(A1)-2)/ЧИСЛСТОЛБ(ИНДЕКС(Table;$C$1+1;$B$1+1):ИНДЕКС(Table;ЧСТРОК(Table);ЧИСЛСТОЛБ(Table)))*$D$1)+1;СТОЛБЕЦ()-ПРОСМОТР(СТОЛБЕЦ();МУМНОЖ(ЕСЛИ({1:2:3}>={1;2;3};$A$1:$C$1*{0;1;1}+{0;1;0};);{1:1:1}))+1-1);ЕСЛИ(ДЛСТР(ИНДЕКС(ИНДЕКС(Table;$C$1+1;1):ИНДЕКС(Table;ЧСТРОК(Table);$B$1);ОТБР((СТРОКА(A1)-2)/ЧИСЛСТОЛБ(ИНДЕКС(Table;$C$1+1;$B$1+1):ИНДЕКС(Table;ЧСТРОК(Table);ЧИСЛСТОЛБ(Table)))*$D$1)+1;1));ИНДЕКС(ИНДЕКС(Table;1;$B$1+1):ИНДЕКС(Table;$C$1;ЧИСЛСТОЛБ(Table));СТОЛБЕЦ()-ПРОСМОТР(СТОЛБЕЦ();МУМНОЖ(ЕСЛИ({1:2:3}>={1;2;3};$A$1:$C$1*{0;1;1}+{0;1;0};);{1:1:1}))+1;ОСТАТ((СТРОКА(A1)-2);ЧИСЛСТОЛБ(ИНДЕКС(Table;$C$1+1;$B$1+1):ИНДЕКС(Table;ЧСТРОК(Table);ЧИСЛСТОЛБ(Table)))/$D$1)*$D$1+1);"");ЕСЛИ(СТОЛБЕЦ()-ПРОСМОТР(СТОЛБЕЦ();МУМНОЖ(ЕСЛИ({1:2:3}>={1;2;3};$A$1:$C$1*{0;1;1}+{0;1;0};);{1:1:1}))+1>$D$1;"";ИНДЕКС(ИНДЕКС(Table;$C$1+1;$B$1+1):ИНДЕКС(Table;ЧСТРОК(Table);ЧИСЛСТОЛБ(Table));ОТБР((СТРОКА(A1)-2)/ЧИСЛСТОЛБ(ИНДЕКС(Table;$C$1+1;$B$1+1):ИНДЕКС(Table;ЧСТРОК(Table);ЧИСЛСТОЛБ(Table)))*$D$1)+1;ОСТАТ((СТРОКА(A1)-2);ЧИСЛСТОЛБ(ИНДЕКС(Table;$C$1+1;$B$1+1):ИНДЕКС(Table;ЧСТРОК(Table);ЧИСЛСТОЛБ(Table)))/$D$1)*$D$1+СТОЛБЕЦ()-ПРОСМОТР(СТОЛБЕЦ();МУМНОЖ(ЕСЛИ({1:2:3}>={1;2;3};$A$1:$C$1*{0;1;1}+{0;1;0};);{1:1:1}))+1))));"")

=ЕСЛИОШИБКА(ЕСЛИ(СТРОКА()=3;ВЫБОР(nn;h_1&"";h_2&"";h_3);ВЫБОР(nn;f_1;f_2;f_3));"")

Sub ExportDSL()
    Dim col As Range, ar As Range, c As Range, c1 As Range
    Dim fs As Object, i&, sColor$, sFilePath$
    
    Set fs = CreateObject("ADODB.Stream")
    
    fs.Open: fs.Type = 2: fs.Charset = "unicode"
    fs.WriteText "Тезаурус" & vbCrLf & vbCrLf

    With ActiveSheet.UsedRange
        fs.WriteText Chr(9) & "[m1][b][c red]<<""" & .Cells(1) & """>>[/c][/b]" & vbCrLf
        For Each col In .Resize(, .Columns.Count - 1).Columns
            
            Select Case col.Column
                Case 1: sColor = "green"
                Case 2: sColor = "dodgerblue"
            End Select 'col.Column
            
            For Each ar In col.SpecialCells(2, 23).Areas
                Set c = IIf(ar.Cells.Count = 1, ar, ar.End(xlDown)(1, 1))
                If HasChild(c) Then
                    fs.WriteText vbCrLf & """" & c & """" & vbCrLf
                    For Each c1 In Range(c(2, 2), c.End(xlDown).Offset(-1, 1)).SpecialCells(2, 23).Cells
                        fs.WriteText Chr(9) & "[m1][b][c " & IIf(HasChild(c1), sColor, _
                            "blueviolet") & "]<<""" & c1 & """>>[/c][/b]" & vbCrLf
                    Next c1
                End If 'HasChild(c)
        Next ar, col
    End With 'ActiveSheet.UsedRange
    
    sFilePath = Application.GetSaveAsFilename(Mid(ThisWorkbook.FullName, 1, _
        InStrRev(ThisWorkbook.FullName, ".") - 1), _
        "Файлы словаря (*.dsl),*.dsl,Текстовые файлы (*.txt),*.txt")
        
    fs.SaveToFile sFilePath, 2: fs.Close: Set fs = Nothing
End Sub
Private Function HasChild(r As Range) As Boolean
    HasChild = IsEmpty(r(2)) And Not IsEmpty(r(2, 2))
End Function

Function xx$(s1$, s2$)
    Dim s$: s = s1 + "Ў" + s2
    xx = s1
    With CreateObject("vbscript.regexp")
        .Global = True: .Pattern = "(.+)(?=.*Ў(?=.*\1))|Ў.*"
        If .test(s) Then xx = .Replace(s, "")
    End With
End Function

Источник = Json.Document(Web.Contents("https://api.rasp.yandex.net/v3.0/schedule/?apikey=хххххххх-хххх-хххх-хххх-хххххххххххх&station=s9610483&" & DateTime.ToText(DateTime.Date(DateTime.LocalNow),"yyyy-MM-dd"))),

.Replace Empty, Addr

Sub Удалить_заголовки_и_пустые()
    Dim Addr$
    With ActiveSheet.UsedRange.Columns("A")
        Addr = "=" & .Resize(1).Offset(.Cells.Count).Address(, , Application.ReferenceStyle, 1)
        With Intersect(.Cells, .Offset(12))
            .Replace "Дата операции", Addr
            .Replace 1, Addr, xlWhole
            .Replace Empty, Addr
        End With
    End With
    Evaluate(Addr).DirectDependents.EntireRow.Delete xlUp
End Sub

Sub CopyRows()
    Dim I As Long
    With Selection.Rows
        For I = .Count To 1 Step -1
            With .Item(I)
                .Offset(1).Insert xlDown, 0
                .AutoFill .Resize(2), 1
                .Cells(2, 6) = "Пр.П"
            End With
        Next
    End With
End Sub