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

使用VBA将rss文件导入Excel

1 个答案: