1 (изменено: vas.crilov, 2018-06-20 11:39:33)

Тема: vba: не выкладывается xml в Excel

Пытаюсь загрузить на лист xlsx xml из интернета вот этим кодом

Sub impRRP()

Dim iRow As Integer, iCol As Integer
    Dim xmlDoc As MSXML2.DOMDocument, xmlRoot As MSXML2.IXMLDOMNode
    Dim xmlNodes As MSXML2.IXMLDOMNode, xmlData As MSXML2.IXMLDOMNode
    Set xmlDoc = New MSXML2.DOMDocument
    
    xmlDoc.async = False
    xmlDoc.validateOnParse = False
    xmlDoc.Load ("https://websvcgatewayx2.frbny.org/autorates_tomo_external/services/v1_0/tomo/retrieveHistoricalXml?f=06192018&t=06202018&ctt=true&&cta=true&ctm=true")

    Set xmlRoot = xmlDoc.DocumentElement
    Set xmlNodes = xmlRoot.FirstChild

    iRow = 0
    For Each xmlNodes In xmlRoot.ChildNodes
        iRow = iRow + 1
        iCol = 0
        For Each xmlData In xmlNodes.ChildNodes
            iCol = iCol + 1
            ThisWorkbook.Sheets(1).Cells(1, iCol) = xmlData.BaseName
            ThisWorkbook.Sheets(1).Cells(iRow, iCol) = xmlData.Text
        Next xmlData
    Next xmlNodes

End Sub

выдает какую то куцую одну строчку. Не могу понять, где ошибка. Помогите пожалуйста.

2

Re: vba: не выкладывается xml в Excel

vas.crilov пишет:
ThisWorkbook.Sheets(1).Cells(1, iCol) = xmlData.BaseName
ThisWorkbook.Sheets(1).Cells(iRow, iCol) = xmlData.Text

Здесь Вы на первом проходе пишете в одну и ту же ячейку (1;1). Зачем? Куда что на самом деле надо писать?

Что Вы вообще хотите получить?

3

Re: vba: не выкладывается xml в Excel

vas.crilov, присоединяюсь к вопросу alexii. Для меня тоже не совсем ясна идея, в каком виде Вы хотите вывести информацию на листе, поэтому сделал пример в базовом виде с рекурсивным перебором и выводом baseName и text и добавил комментарии. Надеюсь это поможет в Вашей задаче.

Скриншот результата:

+ открыть спойлер

https://i.imgur.com/naCENSl.png


'Создание объекта парсера библиотеки Microsoft XML v6.0
Dim Doc As New MSXML2.DOMDocument60
'Объект для хранения ссылки на активный лист
Dim Sheet As Worksheet

'Главная процедура
Sub Main()
    'Получение ссылки на первый лист активной книги
    Set Sheet = ActiveWorkbook.Sheets(1)
    'Отключение асинхронной загрузки документа
    Doc.async = False
    'Загрузка данных с ресурса с проверкой успешности загрузки
    If Not Doc.Load("https://websvcgatewayx2.frbny.org/autorates_tomo_external/services/v1_0/tomo/retrieveHistoricalXml?f=06192018&t=06202018&ctt=true&&cta=true&ctm=true") Then
        Debug.Print "Resource load failed"
        Exit Sub
    End If
    
    With Sheet.Cells
        'Очистка листа
        .ClearContents
        'Заполнение заголовков на листе
        .Item(1, 1) = "BASENAME"
        .Item(1, 2) = "TEXT"
    End With
    'Установка жирного шрифта
    Sheet.Rows(1).Font.Bold = True
    'Передача ссылки на базовый тег документа в процедуру рекурсивного перебора тегов (второй параметр порядковый номер строки с которой начнётся заполнение листа.)
    RecursiveScanNode Doc.DocumentElement, 2
End Sub

'Процедура рекурсивного перебора
Sub RecursiveScanNode(node As MSXML2.IXMLDOMNode, i As Long)  ' As MSXML2.IXMLDOMNode)
    'Переменная для итеративного получения ссылки на дочерние элементы переданного node
    Dim ChildNode As IXMLDOMNode
    'Проверка, что текущий элемент является ветвью (а не текстовым блоком, комментарием, или процессинговой инструкцией и т.п.)
    If node.NodeType = NODE_ELEMENT Then
        'Создание записи на листе
        'Получение базового имени элемента
        Sheet.Cells(i, 1) = node.BaseName
        'Получение текста элемента
        Sheet.Cells(i, 2) = GetNodeText(node)
        i = i + 1
        For Each ChildNode In node.ChildNodes
            RecursiveScanNode ChildNode, i
        Next
    End If
End Sub

'Функция получения текста элемента исключая текст дочерних элементов
Function GetNodeText(node As IXMLDOMNode) As String
    Dim ChildNode As IXMLDOMNode
    For Each ChildNode In node.ChildNodes
        If ChildNode.NodeType = NODE_TEXT Then GetNodeText = GetNodeText & ChildNode.Text
    Next
End Function
Передумал переделывать мир. Пашет и так, ну и ладно. Сделаю лучше свой !