Excel 使用组合框VBA中的选项刮取网站数据_Excel_Vba_Web Scraping

Excel 使用组合框VBA中的选项刮取网站数据

excel vba web-scraping

Excel 使用组合框VBA中的选项刮取网站数据,excel,vba,web-scraping,Excel,Vba,Web Scraping,您好，我正试图从本网站上获取产品名称（Cohiba Robusto）、产品尺寸（一支雪茄，一包3支，一盒25支）和价格（33.65英镑、90英镑、730英镑）：我试图得到这样的东西：我使用下面的代码，它给出了一个错误（“对象变量或未设置变量”）我将非常感谢您的帮助 Sub getproducts() Sheets("JJFox").Select Dim oHtml As HTMLDocument Dim oElement As Object D

您好，我正试图从本网站上获取产品名称（Cohiba Robusto）、产品尺寸（一支雪茄，一包3支，一盒25支）和价格（33.65英镑、90英镑、730英镑）：

我试图得到这样的东西：

我使用下面的代码，它给出了一个错误（“对象变量或未设置变量”）

我将非常感谢您的帮助

Sub getproducts()

Sheets("JJFox").Select

Dim oHtml       As HTMLDocument
Dim oElement    As Object

Dim Elements As IHTMLElementCollection
Dim Document As HTMLDocument

Set oHtml = New HTMLDocument


'Cells(1, 6) = Time()
lastrow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
cnt = lastrow + 1

counter1 = cnt

Dim gg As String

gg = "https://www.jjfox.co.uk/cohiba-robusto-621.html"


Dim objHTTP As New WinHttp.WinHttpRequest
url = gg
    objHTTP.Open "POST", url, False
    objHTTP.setRequestHeader "Content-Type", "application/json"
    objHTTP.send ("{""key"":null,""from"":""me@me.com"",""to"":null,""cc"":null,""bcc"":null,""date"":null,""subject"":""My Subject"",""body"":null,""attachments"":null}")
   
 oHtml.body.innerHTML = objHTTP.responseText
 'Cells(rw, 2) = oHtml.getElementsByTagName("description").innerText

   '    If Not .Document.querySelector("button[aria-label='Close']") Is Nothing Then
     '       .Document.querySelector("button[aria-label='Close']").Click
      '  End If
      
      
    txttitle = oHtml.getElementsByClassName("productcart")(0).innerText
txttitlehtml = oHtml.getElementsByClassName("packsize")(0).innerHTML


txttitle = Mid(txttitle, 1, InStr(1, txttitle, Chr(10)))
'Debug.Print txttitlehtml
'txttitle2 = oHtml.getElementsByClassName("price")(0).innerText

Dim Text As String
Text = GetHTML(gg)


starts = InStr(1, Text, "spConfig =")
endS = InStr(starts + 1, Text, "spConfig")

If starts = 0 Then


    Cells(counter1, 1) = txttitle
    Cells(counter1, 2) = "Single"
    starts = InStr(starts + 1, Text, "productPrice")
    endl = InStr(starts + 1, Text, ",")
    Cells(counter1, 3) = Val(Mid(Text, starts + 14, endl - (starts + 14)))
    Cells(counter1, 4) = "JJFox"
    Cells(counter1, 5) = Now()
     
    Cells(counter1, 7) = gg ' link to the page
    counter1 = counter1 + 1
   
Else


Text = Mid(Text, starts, endS - starts)
'Debug.Print Text
'find how many pack options are avaialble

myTxt = Text
countTxt = "label"

bb = (Len(myTxt) - Len(replace(myTxt, countTxt, ""))) / Len(countTxt) - 1
'End find////////////////////////////////////

varlabel = "class=" & Chr(34) & "label" & Chr(34)


starts = InStr(1, Text, "label") + 1
Text = Mid(Text, starts, Len(Text))
        
        For i = 1 To bb
        
        
        starts = InStr(1, Text, "label")
        
        If InStr(starts, Text, "label") Then
        
        'Show the element's properties
           
        
                Cells(counter1, 1) = txttitle
                Cells(counter1, 2) = Mid(Text, starts + 8, InStr(starts, Text, " \") - (starts + 8))
                
                                       
                        starts = InStr(starts + 1, Text, "oldPrice")
                        endl = InStr(starts + 1, Text, ",")
                        

                Cells(counter1, 3).FormulaR1C1 = Val(Mid(Text, starts + 11, endl - (starts + 11)))
                'Debug.Print Val(Mid(Text, startS + chrs, 6))
                Cells(counter1, 4) = "JJFox"
                Cells(counter1, 5) = Now()
                starts = starts + 1
                Text = Mid(Text, starts, Len(Text))
                Cells(counter1, 7) = gg ' link to the page
                counter1 = counter1 + 1
           End If
        
        Next i
            
End If
'Cells(2, 6) = Time()
End Sub



Function GetHTML(url As String) As String
     With CreateObject("MSXML2.ServerXMLHTTP.6.0")
        .Open "GET", url, False
        .send
        GetHTML = .responseText
    End With
End Function

价格和标签是从脚本标记中动态提取的，您可以使用json解析器将其内容解析为json。但是，您需要从html中获取名称

只要稍微了解一下html和css，就可以很容易地定义css模式，以感兴趣的脚本节点为目标：

.fieldset [type='text/x-magento-init']

它查找具有属性值

text/x-magento-init

的

type

属性的子

script

，以及具有类

fieldset

的父级

我使用了效率稍低一点的方法（你不会注意到）：

这仅仅是因为我知道集合很小，并且允许我用一个循环索引到两个变量中

Json库：

我使用jsonconverter.bas。从名为JsonConverter的标准模块下载原始代码并将其添加到该模块中。从复制的代码中删除顶部属性行

然后你需要去：

VBE>工具>引用>将引用添加到：

Microsoft Scripting Runtime
Microsoft HTML Object Library
Microsoft XML Library.

在VBAForJSON中，[]表示集合，{}表示字典

选项显式
公共分公司GetCigarData（）
“工具>参考：
'Microsoft脚本运行时
'Microsoft HTML对象库
'Microsoft XML库
Dim json作为对象，html作为MSHTML.HTMLDocument，xhr作为MSXML2.XMLHTTP60，ws作为工作表
设置ws=ThisWorkbook.Worksheets（“Sheet1”）
设置xhr=New MSXML2.XMLHTTP60
Set html=New MSHTML.HTMLDocument
使用xhr
.打开“获取”https://www.jjfox.co.uk/cohiba-robusto-621.html”“错
.setRequestHeader“用户代理”、“Mozilla/5.0”
.发送
html.body.innerHTML=.responseText
以
Set json=jsonConverter.ParseJson（html.querySelector（.fieldset[type='text/x-magento-init']）.innerHTML）（“产品添加到零件表单”）（“可配置”（“spConfig”）
将价格设置为脚本。字典，选项设置为脚本。字典，选项集合设置为集合
Set prices=json（“optionPrices”）
Set options=json（“属性”）
设置选项集合=选项（options.Keys（0））（“选项”）
Dim results（）作为变量，headers（）作为变量，i作为长度，name作为字符串
重拨结果（1到选项Collection.Count，1到3）
name=html.querySelector（“.base”）.innerText
对于选项Collection.Count的i=1
结果（i，1）=名称
结果（i，2）=选项集合。项目（i）（“标签”）
结果（i，3）=价格（prices.Keys（i-1））（“最终价格”）（“金额”）
下一个
标题=数组（“名称”、“大小”、“价格”）
与ws
.单元格（1，1）.调整大小（1，UBound（页眉）+1）=页眉
.单元格（2，1）.调整大小（UBound（结果，1），UBound（结果，2））=结果
以
端接头

阅读css选择器：