Импортируйте файл rss в Excel, используя VBA

Question

У меня есть следующий код, который импортирует данные XML (элементы) в Excel.

Sub Test()
Dim rCount As Long
Dim XMLHttpRequest As XMLHTTP
Dim response As String
Dim URL As String
Dim sTemperature As String
Dim xNode As Object
Dim items As Object
Dim FieldIndex As Long
Dim ItemIndex As Long
Dim Node
Dim c As Long

Application.ScreenUpdating = False
rCount = 2
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")

ws.Range("A1").Resize(1, 13).Value = Array("ID", "Title", "Link", "Description", "Product Type 1", "Product Type 2", "Image Link", "Availability", "Price", "Sale Price", "Identifier Exists", "Shipping Weight", "Custom Label")
    Dim xDoc        As MSXML2.DOMDocument
Dim xEmpDetails As MSXML2.IXMLDOMNode
Dim xEmployee   As MSXML2.IXMLDOMNode
Dim xChild      As MSXML2.IXMLDOMNode

Set xDoc = New MSXML2.DOMDocument
xDoc.async = False
xDoc.validateOnParse = False
xDoc.Load (ThisWorkbook.Path & "\Sample.rss")


Set xNode = xDoc.SelectSingleNode("//channel")

Dim strValue As String

For FieldIndex = 3 To xNode.ChildNodes.Length
    c = 1
        Set items = xNode.ChildNodes(FieldIndex)
        If Not items Is Nothing Then
            For ItemIndex = 0 To items.ChildNodes.Length - 1
                If ItemIndex >= 1 Then

                Set Node = items.ChildNodes(ItemIndex)
                Sheet1.Cells(rCount, c).Value = FrontClean(EndClean(Node.nodeTypedValue))
                c = c + 1
                End If
            Next ItemIndex

        End If

        rCount = rCount + 1

Next FieldIndex
Application.ScreenUpdating = True
End Sub
Function FrontClean(param As String) As String
Dim b()     As Byte
Dim i       As Long

b = param
For i = 0 To UBound(b) Step 2
    Select Case b(i)
        Case 0 To 32, 127, 129, 141, 143, 144, 157
        Case Else: Exit For
    End Select
Next i

FrontClean = Mid$(param, (i + 2) \ 2)
End Function

Function EndClean(param As String) As String
Dim b()     As Byte
Dim i       As Long

b = param

For i = UBound(b) - 1 To 0 Step -2
    Select Case b(i)
        Case 0 To 32, 127, 129, 141, 143, 144, 157
        Case Else: Exit For
    End Select
Next i

EndClean = Left$(param, (i + 2) \ 2)
End Function

Результаты должны быть в 13 столбцах, но у меня есть дополнительные столбцы.

Я думаю, что этопотому что некоторые узлы, такие как product_type, могут быть там более одного раза.

Вот снимок

Вот ссылка на файл примера https://www.mediafire.com/file/mym24lljt04us3o/Sample.rss/file

Answer 1

Как отмечено выше - вы можете отслеживать расположение столбцов для каждого поля, чтобы вы могли управлять дубликатами полей или полей в разных порядках.

Проверено:

Sub Test()
    Dim rCount As Long, c As Long
    Dim XMLHttpRequest As XMLHTTP
    Dim itemNode As Object, itemNodes As Object, fieldNode As Object
    Dim dict As Object, elName As String
    Dim ws As Worksheet, xDoc As MSXML2.DOMDocument

    Set dict = CreateObject("scripting.dictionary")

    Application.ScreenUpdating = False
    rCount = 2

    Set ws = ThisWorkbook.Worksheets("Sheet1")

    Set xDoc = New MSXML2.DOMDocument
    xDoc.async = False
    xDoc.validateOnParse = False
    xDoc.Load "C:\Stuff\Sample.rss"

    c = 1
    Set itemNodes = xDoc.SelectNodes("//channel/item")

    For Each itemNode In itemNodes '<< loop over items
        For Each fieldNode In itemNode.ChildNodes '<< loop over item fields
            'ignore comment nodes etc
            If fieldNode.NodeType = NODE_ELEMENT Then

                elName = fieldNode.BaseName '<< get the tag name
                'Check if we've not seen this tag name before
                '  if new then assign it a column number
                If Not dict.exists(elName) Then
                    dict.Add elName, c
                    ws.Cells(1, c).Value = elName
                    c = c + 1
                End If

                'put the node value in the correct column
                '  (add to previous value if duplicate tag)
                With ws.Cells(rCount, dict(elName))
                    .Value = .Value & IIf(.Value <> "", ";", "") & _
                              FrontClean(EndClean(fieldNode.nodeTypedValue))
                End With

            End If
        Next fieldNode
        rCount = rCount + 1

    Next itemNode

    Application.ScreenUpdating = True
End Sub