Страницы: 1
RSS
Макрос вывода в XML со вложенностью
 
Помогите пожалуйста сделать макрос вывода из экселя в xml
Вопрос в том чтобы элементы с одинаковым родительским элементом объединялись -  элемент "Томск" в нем 2 элемента, элемент "Ленина" в нем 3 шт:  
Код
<?xml version="1.0" encoding="UTF-8"?>
<Города xmlns:xs="type">
   <Томск> 
      <Центральная> 
         <Дом id="12" Квартира="434"/>
      </Центральная>
      <Ленина>
         <Дом id="13" Квартира="3"/>
         <Дом id="44" Квартира="23"/>
         <Дом id="25" Квартира="13"/>
      </Ленина> 
   </Томск>    
   <Абакан>
      <Пушкина>
         <Дом id="56" Квартира="23"/>
      <Пушкина>
   </Абакан>   
   <Красноярск>
      <Гоголя>
         <Дом id="14" Квартира="56"/>
      </Гоголя>
      <Партизанов> 
         <Дом id="23" Квартира="18"/>
      </Партизанов> 
      <Чехова>
         <Дом id="74" Квартира="65"/>
      </Чехова>
   </Красноярск>
</Города>
 
объединялись - это как?
какой номер дома получится после объединения домов 13, 44 и 25?
 
Я имею ввиду конечный Xml файл должен по структуре быть
Код
 <Томск> 
      <Центральная> 
         <Дом id="12" Квартира="434"/>
      </Центральная>
      <Ленина>
         <Дом id="13" Квартира="3"/>
         <Дом id="44" Квартира="23"/>
         <Дом id="25" Квартира="13"/>
      </Ленина> 
   </Томск> 
а не так
Код
 <Томск> 
      <Центральная> 
         <Дом id="12" Квартира="434"/>
      </Центральная>
      <Ленина>
         <Дом id="13" Квартира="3"/>
      </Ленина> 
      <Ленина>
         <Дом id="44" Квартира="23"/>
      </Ленина> 
      <Ленина>
         <Дом id="25" Квартира="13"/>
      </Ленина> 
   </Томск>
 
Макрос пришлось сильно переделывать:
Код
Sub Convert_Excel_Data_to_XML()

    Dim doc As MSXML2.DOMDocument60
    Dim rng As Range, rngRow As Range
    Dim root As MSXML2.IXMLDOMElement
    Dim child As MSXML2.IXMLDOMElement
    Dim xmlDecl As MSXML2.IXMLDOMProcessingInstruction
    Dim sXmlFilePath As String

    'Создаём новый XML документ
    Set doc = New MSXML2.DOMDocument60

    'Путь для сохранения XML файла
    sXmlFilePath = ThisWorkbook.Path & "\Output.xml"

    'XML декларация
    Set xmlDecl = doc.createProcessingInstruction("xml", "version='1.0' encoding='UTF-8'")
    doc.appendChild xmlDecl

    'Добавляем корневой элемент
    Set root = doc.createElement("Города")
    root.setAttribute "xmlns:xs", "type"
    doc.appendChild root

    'Добавляем новый элемент в корневой элемент
    On Error Resume Next
    Set rng = Range(Range("a2"), Range("a" & Rows.Count).End(xlUp)).Resize(, 4)
    Dim cities As New Collection, streets As New Collection
    Dim city_node As MSXML2.IXMLDOMElement, street_node As MSXML2.IXMLDOMElement, city$, street$

    For Each rngRow In rng.Rows
        city$ = rngRow.Cells(1):        street$ = rngRow.Cells(2)

        Err.Clear: cities.Add city$, city$
        If Err = 0 Then Set city_node = root.appendChild(doc.createElement(city$)): Set streets = New Collection

        Err.Clear: streets.Add street$, street$
        If Err = 0 Then Set street_node = city_node.appendChild(doc.createElement(street$))

        With street_node.appendChild(doc.createElement("Дом"))
           .Attributes.setNamedItem(doc.createAttribute("id")).Text = rngRow.Cells(3)
           .Attributes.setNamedItem(doc.createAttribute("Квартира")).Text = rngRow.Cells(4)
        End With
    Next

    'Сохраняем XML файл
    doc.Save sXmlFilePath

    Debug.Print sXmlFilePath
End Sub

результат:
 
Спасибо большое буду разбираться!)
Страницы: 1
Наверх