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

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

excel vba

Excel宏，用于使用Excel数据搜索网站并提取特定结果，然后循环查找另一个网站的下一个值,excel,vba,Excel,Vba,虽然在URL\u get\u SKU\u Query1=entityRange.Offset（0，1）.Value2行中出现错误，说明“对象变量或未设置块变量” 所以我只是想复制另一个网站的代码。这段代码拉入某个文本并从webiste中输出一个值因此，我想在表1中输入制造商SKU，如下所示：名称//库存单位//价格节水水龙头//SS902BC 在我在工作表2上创建了一个宏按钮并单击它之后然后让它说出价格因此，结果如下所示：名称//库存单位//价格节水水龙头//SS902BC//9

虽然在URL\u get\u SKU\u Query1=entityRange.Offset（0，1）.Value2行中出现错误，说明“对象变量或未设置块变量”

所以我只是想复制另一个网站的代码。这段代码拉入某个文本并从webiste中输出一个值

因此，我想在表1中输入制造商SKU，如下所示：

名称//库存单位//价格节水水龙头//SS902BC

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

然后让它说出价格

因此，结果如下所示：

名称//库存单位//价格节水水龙头//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

问题是由于各种原因，

Range.Find

可能找不到您要查找的内容，因为它可以“方便地记住”上次调用它时的值——或者来自其他VBA代码，或者通过Excel UI（如果不指定值，则无法100%确定它将使用哪些值运行）。但即便如此，如果

Range.Find

没有找到它要查找的内容，它也会返回

Nothing

——而且你不能假设这永远不会发生

但是，仔细阅读

有人在撒谎。阅读评论。现在读代码。谁说的是实话？不要写注释说“什么”——让注释说“为什么”，让代码说“什么”。否则，您会遇到这样的情况，即无法判断注释是否过时或代码是否正确，至少在不查看工作表的情况下是如此

在任何情况下，您都需要确保

entityRange

不是

Nothing

，然后才能尝试对其进行成员调用：

If Not entityRange Is Nothing Then
    URL_Get_SKU_Query1 = entityRange.Offset(0, 1).Value2
End If

不幸的是，你的逻辑有缺陷。你不能简单地从一个网页上取下这个机制，然后假设它能为下一个网页工作。在这种情况下，您尝试的解决方案将不起作用。当您在搜索中输入SKU时，实际发生的是页面重定向（302）。而不是像您尝试过的那样构建url。您看到的错误主要是由于点击了一个找不到的页面——尽管由于404页面上找不到您的元素而出现了表面

相反，您可以使用所讨论的页面实际用于初始url的构造，然后可以使用xmlhttp，它将遵循如下re direct：

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

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

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

必需的项目参考资料：

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

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

两个红色边界的参考是必需的。按Alt+F11打开VBE，然后转到

Tools>References

并添加引用。您可能有一个不同的xml库版本号-在这种情况下，引用需要更改，其代码引用也需要更改

Dim xhr As XMLHTTP60

及

要运行此代码：

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

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

按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()
    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

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

选项显式
公共分包价格（）
Dim xhr作为XMLHTTP60，html作为HTMLDocument，ws作为工作表，i作为长
设置ws=ThisWorkbook.Worksheets（“Sheet1”）
设置xhr=newxmlhttp60
设置html=新的HTMLDocument
Dim allData（），价格作为对象
allData=ws.UsedRange.Value
使用xhr
对于i=2到UBound（所有数据，1）
.打开“获取”https://www.neobits.com/search?keywords=&所有数据（i，2），错误
.发送
如果。状态200那么
allData（i，3）=“Status not Successed”’也许可以为我们提供完整的工作url和预期结果？请检查我对您文章的编辑，看看它是否准确地代表了您预期的完整代码文章。然后看看是否可以将代码量减少到演示问题所需的数量。您好，谢谢您的输入，我已更改了链接，以便将您指向我最初发现代码的位置。我已经测试了链接中的代码，它工作正常，并提供了关于我希望代码做什么的更多信息。你不能简单地假设你可以传输逻辑。您需要有效的URL。至少对我来说，没有找到构造yeilds 404页面。除非我遗漏了什么（完全可能），否则您的错误原因是无效的url，这意味着您以后的选择器将找不到；工作正常，但我不确定是什么“SearchByABN.aspx？SearchText=means，这种编码背后有什么原因吗？”？如果你能帮我修改我的网址，使其正常工作，我将不胜感激。例如，当我进入excel并执行宏时，我想要这个URL中的价格。哇！非常感谢您给出这个有力的回答。我是这个社区的新成员，这是我的第一个问题，我可以看到这是一个可以提问和学习的伟大社区。我将把这些知识带到任何未来的项目中。谢谢你是如此伟大的老师，我非常感激你。