VBA 脚本从网站中提取数据

Question

我想从http://www.buyshedsdirect.co.uk/ 中提取数据以获取特定商品的最新价格。

我有一个包含以下内容的 Excel 电子表格：

|A | B
1 |Item |Price
2 |bfd/garden-structures/arches/premier-arches-pergola

和 VBA 脚本：

Dim ie As New InternetExplorer
Dim item As String
item = Sheet1.Range("A2").Value
Dim doc As HTMLDocument

ie.Visible = True
ie.navigate "http://www.buyshedsdirect.co.uk/" & item

Do
    DoEvents
    Loop Until ie.readyState = READYSTATE_COMPLETE

Set doc = ie.document
On Error Resume Next
output = doc.getElementByClass("NowValue").innerText
Sheet1.Range("B2").Value = output

ie.Quit

End Sub

我是 VBA 脚本的新手，不知道为什么它没有从“NowValue”类中提取值

任何帮助将不胜感激:)

Answer 1

On Error Resume Next 行正在阻止显示错误消息。该错误消息是 HTMLDocument 上没有名为“getElementByClass”的方法。您可能想要“getElementsByClassName”，并且必须处理这样一个事实，即它返回一个集合而不是单个元素。这样的代码可以工作：

Option Explicit

Sub foo()

Dim ie As New InternetExplorer
Dim item As String
item = Sheet1.Range("A2").Value
Dim doc As HTMLDocument

ie.Visible = True
ie.navigate "http://www.buyshedsdirect.co.uk/" & item

Do
    DoEvents
Loop Until ie.readyState = READYSTATE_COMPLETE

Set doc = ie.document

Dim results As IHTMLElementCollection
Dim result As IHTMLElement
Dim output As String

Set results = doc.getElementsByClassName("NowValue")
output = ""
For Each result In results
    output = output & result.innerText
Next result

Sheet1.Range("B2").Value = output

ie.Quit

End Sub

然后您会发现该页面上有多个具有“NowValue”类的元素。看起来你想要的可能包含在一个名为“VariantPrice”的 div 中，所以这段代码应该可以工作：

Option Explicit

Sub bar()

Dim ie As New InternetExplorer
Dim item As String
item = Sheet1.Range("A2").Value
Dim doc As HTMLDocument

ie.Visible = True
ie.navigate "http://www.buyshedsdirect.co.uk/" & item

Do
    DoEvents
Loop Until ie.readyState = READYSTATE_COMPLETE

Set doc = ie.document

Dim results As IHTMLElementCollection
Dim results2 As IHTMLElementCollection
Dim result As IHTMLElement
Dim result2 As IHTMLElement
Dim output As String

Set results = doc.getElementsByClassName("VariantPrice")
output = ""
For Each result In results
    Set results2 = result.getElementsByClassName("NowValue")
    For Each result2 In results2
        output = output & result2.innerText
    Next result2
Next result

Sheet1.Range("B2").Value = output

ie.Quit

End Sub

edit: 因为上面的代码对我来说非常有效，但对提问者却不起作用，可能是他们使用的是不支持 @987654326 的旧版本的 Internet Explorer @。可能会使用 querySelector 代替。要确定，请转到this QuirksMode page 以确定您的浏览器到底支持什么。

使用querySelector的新代码：

Option Explicit

Sub bar()

Dim ie As New InternetExplorer
Dim doc As HTMLDocument
Dim result As IHTMLElement
Dim result2 As IHTMLElement
Dim item As String

item = Sheet1.Range("A2").Value

ie.Visible = True
ie.navigate "http://www.buyshedsdirect.co.uk/" & item

Do
    DoEvents
Loop Until ie.readyState = READYSTATE_COMPLETE

Set doc = ie.document

Set result = doc.querySelector(".VariantPrice")
Set result2 = result.querySelector(".NowValue")

Sheet1.Range("B2").Value = result2.innerText

ie.Quit

End Sub

进一步编辑： 使宏循环遍历 A 列中的所有条目，以下是要添加或更改的相关位：

Option Explicit

Sub bar()

Dim ie As New InternetExplorer
Dim doc As HTMLDocument
Dim result As IHTMLElement
Dim result2 As IHTMLElement
Dim item As String
Dim lRow As Long

ie.Visible = True
lRow = 2
item = Sheet1.Range("A" & lRow).Value

Do Until item = ""
    ie.navigate "http://www.buyshedsdirect.co.uk/" & item

    Do
        DoEvents
    Loop Until ie.readyState = READYSTATE_COMPLETE

    Set doc = ie.document

    Set result = doc.querySelector(".VariantPrice")
    Set result2 = result.querySelector(".NowValue")

    Sheet1.Range("B" & lRow).Value = result2.innerText

    lRow = lRow + 1
    item = Sheet1.Range("A" & lRow).Value   
Loop

ie.Quit

End Sub