<xs:import namespace="http://www.w3.org/2001/XMLSchema"/>

<xs:element ref="xs:schema"/>

cd /d .
AltovaXML -xslt2 xsl\main.xslt -in xsd\test1.xsd -param SourceFilePath='%~dp0src\test.xlsx'
pause

Dim sFolder
sFolder = Replace(WScript.ScriptFullName, WScript.ScriptName, "")
With CreateObject("AltovaXML.Application").XSLT2
    .InputXMLFileName = sFolder & "xsd\test1.xsd"
    .XSLFileName = sFolder & "xsl\main.xslt"
    .AddExternalParameter "SourceFilePath", "'" & sFolder & "src\test.xlsx'"
    .AddExternalParameter "DestFolder", "'" & sFolder & "'"
    .AddExternalParameter "DestFIle", "'test1.xml'"
    .Execute ""
End With

Dim sFolder
sFolder = Replace(WScript.ScriptFullName, WScript.ScriptName, "")
With CreateObject("AltovaXML.Application").XSLT2
    .InputXMLFromText = "<xs:schema id='NewDataSet' xmlns='' xmlns:xs='http://www.w3.org/2001/XMLSchema' xmlns:msdata='urn:schemas-microsoft-com:xml-msdata'>" & vbCrLf & _
    "<xs:element name='NewDataSet' msdata:IsDataSet='true' msdata:MainDataTable='OrderHeader' msdata:UseCurrentLocale='true'>" & vbCrLf & _
    "<xs:complexType>" & vbCrLf & _
    "<xs:choice minOccurs='0' maxOccurs='unbounded'>" & vbCrLf & _
        "<xs:element name='OrderHeader'>" & vbCrLf & _
        "<xs:complexType>" & vbCrLf & _
        "<xs:sequence>" & vbCrLf & _
        "<xs:element name='Id' type='xs:string' minOccurs='0' />" & vbCrLf & _
        "<xs:element name='Cl' type='xs:string' minOccurs='0' />" & vbCrLf & _
        "</xs:sequence>" & vbCrLf & _
        "</xs:complexType>" & vbCrLf & _
        "</xs:element>" & vbCrLf & _
    "</xs:choice>" & vbCrLf & _
    "</xs:complexType>" & vbCrLf & _
    "</xs:element>" & vbCrLf & _
    "</xs:schema>"
    .XSLFileName = sFolder & "xsl\main.xslt"
    .AddExternalParameter "SourceFilePath", "'" & sFolder & "src\test.xlsx'"
    .AddExternalParameter "DestFolder", "'" & sFolder & "'"
    .AddExternalParameter "DestFIle", "'test1.xml'"
    .Execute ""
End With

DBASE IV;CharacterSet=65001

[Красный][<1,5]Основной;Основной

Sub sdf()
    On Error Resume Next
    Dim cell As Range, sPath$, sNewPath$, sHref$
    sPath = ThisWorkbook.Path & "\"
    sNewPath = sPath & "Отчет" & Format(Now, "dd.MM.yyyy hh_mm\\")
    MkDir sNewPath
    With ActiveSheet.UsedRange.Columns("K")
        For Each cell In Intersect(.Cells, .Offset(1)).SpecialCells(2, 23).SpecialCells(12).Cells
            sHref = cell.Hyperlinks(1).Address
            FileCopy sPath & sHref, sNewPath & Mid(sHref, InStrRev(sHref, "\") + 1)
        Next
    End With
End Sub

    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