Set qt1 = wsl.QueryTables.Add(Connection:="TEXT;" & "E:\Data\TXT", Destination:=wsl.Cells(1, 1))

        With qt1
            .FieldNames = False
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = False
            .RefreshPeriod = 0
            .TextFilePromptOnRefresh = True
            .TextFilePlatform = 866
            .TextFileStartRow = 1
            .TextFileParseType = xlDelimited
            .TextFileConsecutiveDelimiter = False
            .TextFileTabDelimiter = False
            .TextFileSemicolonDelimiter = True
            .TextFileCommaDelimiter = False
            .TextFileSpaceDelimiter = False
            .TextFileColumnDataTypes = Array(1, 1, 4, 1, 1, 1, 1, 1, 1, 1)
            .TextFileTrailingMinusNumbers = True
            .Refresh BackgroundQuery:=False
            Debug.Print Split(.Connection, ";")(1)
        End With

=ЕСЛИОШИБКА(ИНДЕКС($B$2:$B$325;НАИМЕНЬШИЙ(ЕСЛИ((ДАТА(ГОД(СЕГОДНЯ());МЕСЯЦ($C$2:$C$325);ДЕНЬ($C$2:$C$325))-СЕГОДНЯ()>=0)*(ДАТА(ГОД(СЕГОДНЯ());МЕСЯЦ($C$2:$C$325);ДЕНЬ($C$2:$C$325))-СЕГОДНЯ()<=30);СТРОКА($B$2:$B$325)-СТРОКА($B$1));A4));"")

=ЕСЛИОШИБКА(ИНДЕКС(B:B;НАИМЕНЬШИЙ(ЕСЛИ((--(ТЕКСТ(C$2:C$325;"[>0]д.М.;")&ГОД(СЕГОДНЯ()))>СЕГОДНЯ())*(C$2:C$325-(ТЕКСТ(СЕГОДНЯ();"д.М.")&ГОД(C$2:C$325))<30);СТРОКА(C$2:C$325));СТРОКА(F1)));"")

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

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

.Replace Empty, Addr

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

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

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

=ЕСЛИОШИБКА(ЕСЛИ(СТРОКА()=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));"")

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

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

For Each iFile In Folder.Files

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