Question

我正在尝试从此Zillow URL中提取多个项目（XML节点）。我的代码包含一个for每个循环，每个循环只能拉一个节点（项目），但我需要用URL上的可用数据填充其他列

我尝试添加一个变量来提取此节点，但是在提取一些数据后，我总是以“运行时错误'91'：对象变量或未设置块变量”结束

这是一个有效的VBA代码，用于提取单个项目

 URLs = ThisWorkbook.Worksheets("URLLIST").Range("B4:B" & URLCount).Value



Set xmlDocument = New MSXML2.DOMDocument60
xmlDocument.async = False
' xmlDocument.validateOnParse = False

For i = LBound(URLs, 1) To UBound(URLs, 1)
    xmlDocument.Load URLs(i, 1)
    Set nodeId = xmlDocument.SelectSingleNode("//response/results/result/zestimate/amount")
    Set nodeId2 = xmlDocument.SelectSingleNode("//response/results/result/finishedSqFt")


    If Not nodeId Is Nothing Then
    With Sheets("ZILLOW DATA")
        NextRow = .Range("E" & Rows.Count).End(xlUp).Row + 1
        .Range("E" & NextRow).Value = nodeId.Text

    End With

Else
    With Sheets("ZILLOW DATA")
        NextRow = .Range("E" & Rows.Count).End(xlUp).Row + 1
        .Range("E" & NextRow).Value = "N/A"

    End With

    End If
Set nodeId = Nothing: Set nodeId2 = Nothing
Next

这是我要拉出的一些物品的屏幕截图

Answer 1

这对我有用...

Public Sub ExtractXml()
    Dim objHttp As XMLHTTP60, objXml As DOMDocument60, strUrl As String
    Dim objDict As Scripting.Dictionary, strValue As String, lngWriteRow As Long
    Dim objCell As Range

    Set objHttp = New XMLHTTP60
    Set objXml = New DOMDocument60

    Set objDict = New Scripting.Dictionary

    objDict.Add "//amount", "A"
    objDict.Add "//finishedSqFt", "B"
    objDict.Add "//bathrooms", "C"
    objDict.Add "//bedrooms", "D"

    For Each objCell In Worksheets("URLLIST").Range("B4:B500")
        strUrl = objCell.Text

        If strUrl <> "" Then
            With objHttp
                .Open "GET", strUrl, False
                .send
            End With

            If objXml.LoadXML(objHttp.responseText) Then
                On Error Resume Next

                lngWriteRow = lngWriteRow + 1

                For i = 0 To objDict.Count - 1
                    Err.Clear

                    strValue = objXml.DocumentElement.SelectSingleNode(CStr(objDict.Keys(i))).Text

                    If Err.Description <> "" Then
                        strValue = "Not Found"
                    End If

                    Sheet1.Range(CStr(objDict.Items(i) & lngWriteRow)) = strValue
                Next

                On Error GoTo 0
            End If
        End If
    Next
End Sub

...添加 Scripting.Dictionary 作为参考，然后循环遍历动态提取所需的节点及其内部文本值。 lngWriteRow是每当您查询属性时都会增加的行。

objDict是您需要添加XPath查询的位置，然后词典中的项目就是您要将其写出的关联列。

使之适应您的URL列表，然后在每次进行新查询时增加lngWriteRow。

如果未找到节点，则它将显示...

未找到

...在相应字段中。

说实话，不确定是否有帮助，但对我有用。我需要更多的URL才能进行全面测试。

如何从单个循环中提取多个项目并填充多个列

1 个答案: