Excel 宏用于使用 excel 数据搜索网站并提取特定结果，然后循环获取另一个网站的下一个值

Question

我已经复制了 Excel macro to search a website with excel data and extract specific results and then loop for next value 中的代码，虽然我在 URL_Get_SKU_Query1 = entityRange.Offset(0, 1).Value2 行收到错误，说明“对象变量或未设置 block 变量”

所以我只是想复制另一个网站的代码。
此代码提取特定文本并从 webiste 中吐出一个值。

所以我想在表 1 中输入 MFR SKU:

名称//SKU//价格
节水水龙头//SS902BC

在我在工作表 2 上创建一个宏按钮并单击它之后

然后让它吐出价格。

所以它最终如下所示:

名称//SKU//价格
节水水龙头//SS902BC//979.08

我需要这个才能在网站上查找多个项目。

Sub LoopThroughBusinesses1()
    Dim i As Integer
    Dim SKU As String
    For i = 2 To Sheet1.UsedRange.Rows.Count
        SKU = Sheet1.Cells(i, 2)
        Sheet1.Cells(i, 3) = URL_Get_SKU_Query1(SKU)
    Next i
End Sub

Function URL_Get_SKU_Query1(strSearch As String) As String ' Change it from a Sub to a Function that returns the desired string
    ' strSearch = Range("a1") ' This is now passed as a parameter into the Function
    Dim entityRange As Range
    With Sheet2.QueryTables.Add( _
         Connection:="URL;https://www.neobits.com/SearchBySKU.aspx?SearchText=" & strSearch & "&safe=active", _
         Destination:=Sheet2.Range("A1"))        ' Change this destination to Sheet2

        .BackgroundQuery = True
        .TablesOnlyFromHTML = True
        .Refresh BackgroundQuery:=False
        .SaveData = True
    End With

    ' Find the Range that has "Price"
    Set entityRange = Sheet2.UsedRange.Find("Price")

    ' Then return the value of the cell to its' right
    URL_Get_SKU_Query1 = entityRange.Offset(0, 1).Value2

    ' Clear Sheet2 for the next run
    Sheet2.UsedRange.Delete

End Function

Answer 1

不幸的是，您的逻辑有缺陷。您不能简单地从一个网页中获取该机制并假设它适用于下一个网页。在这种情况下，您尝试的解决方案将不起作用。当您在搜索中输入 SKU 时，实际发生的是页面重定向 (302)。不是您尝试过的网址构建。您看到的错误主要是由于点击了未找到的页面 - 尽管由于在 404 页面上未找到您的元素而导致的表面。

相反，您可以使用相关页面实际用于初始 url 的构造，然后您可以使用 xmlhttp 它将遵循重定向，如下所示:

VBA:

Option Explicit
Public Sub GetPrices()
    Dim xhr As XMLHTTP60, html As HTMLDocument, ws As Worksheet, i As Long

    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set xhr = New XMLHTTP60
    Set html = New HTMLDocument

    Dim allData()
    allData = ws.UsedRange.Value

    With xhr
        For i = 2 To UBound(allData, 1)
            .Open "GET", "https://www.neobits.com/search?keywords=" & allData(i, 2), False
            .send
            Dim price As Object
            html.body.innerHTML = .responseText
            Set price = html.querySelector("#main_price")
            If Not price Is Nothing Then
                allData(i, 3) = price.innerText
            Else
                allData(i, 3) = "No price found"
            End If
            Set price = Nothing
        Next
    End With
    ws.Cells(1, 1).Resize(UBound(allData, 1), UBound(allData, 2)) = allData
End Sub

我假设您在 Sheet1 中的页面设置如下:



所需项目引用:



需要用红色限定的两个引用。按 Alt+F11 打开 VBE 然后转到 Tools > References并添加引用。您可能对 xml 库有不同的版本号 - 在这种情况下，引用将需要更改，代码引用也需要更改

Dim xhr As XMLHTTP60

和

New XMLHTTP60

要运行此代码:

按 Alt+F11 打开 VBE > 在项目资源管理器中单击鼠标右键 > 添加标准模块。将代码粘贴到该标准模块中 > 选择代码内的任意位置并按 F5，或点击绿色 Run功能区中的箭头。

例如，您可以进一步开发以处理非 200 状态代码:

Option Explicit
Public Sub GetPrices()
    Dim xhr As XMLHTTP60, html As HTMLDocument, ws As Worksheet, i As Long

    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set xhr = New XMLHTTP60
    Set html = New HTMLDocument

    Dim allData(), price As Object
    allData = ws.UsedRange.Value

    With xhr
        For i = 2 To UBound(allData, 1)
            .Open "GET", "https://www.neobits.com/search?keywords=" & allData(i, 2), False
            .send
                If .Status <> 200 Then
                    allData(i, 3) = "Status not succeeded" '<== Little bit loose but you get the idea.
                Else
                    html.body.innerHTML = .responseText
                    Set price = html.querySelector("#main_price")
                    If Not price Is Nothing Then
                        allData(i, 3) = price.innerText
                    Else
                        allData(i, 3) = "No price found"
                    End If
                Set price = Nothing
            End If
        Next
    End With
    ws.Cells(1, 1).Resize(UBound(allData, 1), UBound(allData, 2)) = allData
End Sub