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