Макросы в Excel

Sub XMLExport()
    Dim Заголовок As Range, Данные As Range
    Set Заголовок = Range("a1:f1")
    Set Данные = Range([A2], Range("A" & Rows.Count).End(xlUp)).Resize(, Заголовок.Columns.Count)

    arrHeaders = Application.Transpose(Application.Transpose(Заголовок.Value))
    ПутьКФайлуXML = ThisWorkbook.Path & "\result.xml"

    ' формируем DOMDocument, и сохраняем XML в файл result.xml
   Array2XML(Данные.Value, arrHeaders, "Root").Save ПутьКФайлуXML

    If Err = 0 Then MsgBox "Создан XML файл" & vbNewLine & ПутьКФайлуXML, vbInformation, "Готово"
End Sub

Function Array2XML(ByVal arrData, ByVal arrHeaders, ByVal strHeading$) As DOMDocument
    ' получает в качестве параметров:
   ' двумерный массив arrData с данными для выгрузки,
   ' одномерный массив arrHeaders, содержащий заголовки столбцов,
   ' и strHeading$ - XML-константу объекта
   Dim xmlDoc As DOMDocument, xmlFields As IXMLDOMElement, xmlField As IXMLDOMElement
    Set xmlDoc = CreateObject("Microsoft.XMLDOM")  ' создаём новый DOMDocument

    DataColumnsCount% = UBound(arrData, 2) - LBound(arrData, 2) + 1
    HeadersCount% = UBound(arrHeaders) - LBound(arrHeaders) + 1
    If DataColumnsCount% <> HeadersCount% Then MsgBox "Количество заголовков в массиве arrHeaders" & _
       "не соответствует количеству столбцов массива", vbCritical, "Ошибка создания XML": End

    xmlDoc.loadXML Replace("<" + strHeading + "/>", " ", "_")    ' записываем XML-константу объекта

    For i = LBound(arrData) To UBound(arrData)
        ' создание нового узла
       Set xmlFields = xmlDoc.documentElement.appendChild(xmlDoc.createElement("Row"))

        For j = LBound(arrHeaders) To UBound(arrHeaders)    ' добавление полей в узел
           Set xmlField = xmlFields.appendChild(xmlDoc.createElement(Replace(arrHeaders(j), " ", "_")))
            xmlField.Text = arrData(i, j + LBound(arrData, 2) - LBound(arrHeaders))
        Next j
    Next i

    Set Array2XML = xmlDoc
End Function