Sub BuildXML()

    Dim dXMLDokument, Xmlnode
    Dim snode, gost
    Set dXMLDokument = CreateObject("Microsoft.XMLDOM")

    With dXMLDokument
        .appendChild .createProcessingInstruction("xml", "version=""1.0"" encoding=""UTF-8""")

        Set Xmlnode = .createNode(1, "gost:application", "urn://fgis-arshin.gost.ru/module-verifications/import/2020-06-19")
        .appendChild Xmlnode
    End With
    Set gost = dXMLDokument.createElement("gost:result")
    Xmlnode.appendChild gost

    Set snode = dXMLDokument.createElement("gost:miInfo")
    gost.appendChild snode
    Set singleMI = dXMLDokument.createElement("gost:singleMI")
    snode.appendChild singleMI
    Set Node = dXMLDokument.createElement("gost:mitypeNumber")
    Node.Text = "60935-15"
    singleMI.appendChild Node
    Set Node = dXMLDokument.createElement("gost:manufactureNum")
    Node.Text = "212185"
    singleMI.appendChild Node
    Set Node = dXMLDokument.createElement("gost:modification")
    Node.Text = "СГГ-20Микро-01"
    singleMI.appendChild Node
    dXMLDokument.Save "C:\Output.xml"
End Sub

Sub Test()
    Путь_К_Файлу = "C:\Users\Сергей\Downloads\zip1.txt"
    sl$ = ""
    S$ = Read_Text(Путь_К_Файлу)
    Set RegExp = CreateObject("VBScript.RegExp")
    RegExp.Global = True
    RegExp.IgnoreCase = True
    RegExp.Pattern = "<text:p text:style-name=""Preformatted_20_Text"">(.+?)</text:p>"
    Set oMatches = RegExp.Execute(S)

    For n = 0 To oMatches.Count - 1
        sl$ = sl$ & oMatches(n).subMatches(0)
    Next
    sl = Replace(sl, ">", ">")
    sl = Replace(sl, "<", "<")
    sl = Replace(sl, """, Chr(34))
    sl = Replace(sl, "&#x0d;", Chr(13))
    sl = "<?xml version=""1.0"" encoding=""UTF-8""?><documentElement>" & sl & "</documentElement>"
    Writer_To sl, "E:\1.xml"

End Sub

Public Function Writer_To(strUnicode As String, FileName As String)

    Const adTypeBinary = 1
    Const adTypeText = 2
    Const bOverwrite = True
    Const bAsASCII = False
    Dim oFS: Set oFS = CreateObject("Scripting.FileSystemObject")
    Dim oTo: Set oTo = CreateObject("ADODB.Stream")
    Dim sTo: sTo = "utf-8"
    Dim sTFSpec: sTFSpec = oFS.GetAbsolutePathName(FileName)
    If oFS.FileExists(sTFSpec) Then oFS.DeleteFile sTFSpec
    oTo.Type = adTypeText
    oTo.Charset = sTo
    oTo.Open
    oTo.WriteText strUnicode
    oTo.SaveToFile sTFSpec
    oTo.Close

End Function
Function Read_Text(Путь_К_Файлу) As String
    Dim oStream
    Dim S As String
    Set oStream = CreateObject("ADODB.Stream")
    oStream.Type = 2
    oStream.Charset = "utf-8"
    oStream.Open
    oStream.LoadFromFile Путь_К_Файлу
    Read_Text = oStream.ReadText
    oStream.Close
End Function

Sub Макрос1()
    Dim Sh As Worksheet, A()
    Set Sh = ThisWorkbook.Worksheets(1)
    Set AL = CreateObject("system.collections.arraylist")
    LastRow = Sh.Cells(Sh.Rows.Count, 1).End(xlUp).Row
    dx = Sh.Range("a4:e" & LastRow)
    LastRow = 3
    Set C_is = CreateObject("scripting.dictionary")
    For n = 1 To UBound(dx)
        Key$ = dx(n, 1) & "_" & dx(n, 2) & "_" & dx(n, 3) & "_" & dx(n, 4)
        If C_is.Exists(Key$) Then
            AL.Add dx(n, 5)
        Else
            If C_is.Count > 0 Then
                A = AL.ToArray
                LastRow = LastRow + 1
                Items = C_is.Items
                Item = Items(0)
                Sh.Range("I" & LastRow).Resize(1, UBound(Item) + 1) = Item
                Sh.Range("Q" & LastRow).Resize(1, UBound(A) + 1) = A
            End If
            C_is.RemoveAll
            AL.Clear
            AL.Add dx(n, 5)
            C_is.Item(Key$) = Array(dx(n, 1), dx(n, 2), dx(n, 3), dx(n, 4))
        End If
    Next

    If C_is.Count > 0 Then
        A = AL.ToArray
        LastRow = LastRow + 1
        Items = C_is.Items
        Item = Items(0)
        Sh.Range("I" & LastRow).Resize(1, UBound(Item) + 1) = Item
        Sh.Range("Q" & LastRow).Resize(1, UBound(A) + 1) = A
    End If

End Sub