在特定单元格中导入Excel数据

Question

我想列举设备并将它们的价格放在旁边。

我的目标是每周检查不同的网站并注意趋势。

这是一个爱好项目，我知道有网站已经这样做。

例如：

Device | URL Site 1 | Site 1 | URL Site 2 | Site 2 
Device a | http://... | €40,00 | http://... | €45,00 
Device b | http://... | €28,00 | http://... | €30,50 

手动，这是很多的工作（每周检查），所以我想在Excel宏会有所帮助。事情是，我想将数据放在一个单元格中，并且excel只能识别表格。解决方案：查看源代码，读取价格，导出价格到特定单元格。

我认为这在Excel中是完全可能的，但我无法安静地弄清楚如何读取价格或其他给定数据以及如何将其放入一个特定单元格中。我可以在源代码中指定坐标，还是有更有效的思维方式？

提前致谢，欢迎提供所有提示和解决方案！

Answer 1

首先，你必须找出网站是如何工作的。对于page，您问我已完成以下操作：

• 在Chrome中打开了http://www.mediamarkt.de页面。
• 在搜索框中键入BOSCH WTW 85230，出现了建议列表。
• 按下F12打开开发人员工具并单击网络选项卡。
• 每次我打字，新的请求出现（见黄色区域）：

• 点击请求审查一般信息：

您可以看到它使用GET方法和一些参数，包括url编码的产品名称。

• 点击响应选项卡检查数据从服务器返回：

你可以看到它是一个普通的JSON，全文如下：

{"suggestions":[{"attributes":{"energyefficiencyclass":"A++","modelnumber":"2004975","availabilityindicator":"10","customerrating":"0.00000","ImageUrl":"http://pics.redblue.de/artikelid/DE/2004975/CHECK","collection":"shop","id":"MediaDEdece2358813","currentprice":"444.00","availabilitytext":"Lieferung in 11-12 Werktagen"},"hitCount":0,"image":"http://pics.redblue.de/artikelid/DE/2004975/CHECK","name":"BOSCH WTW 85230 Kondensationstrockner mit Warmepumpentechnologie (8 kg, A++)","priority":9775,"searchParams":"/Search.ff?query=BOSCH+WTW+85230+Kondensationstrockner+mit+W%C3%A4rmepumpentechnologie+%288+kg%2C+A+%2B+%2B+%29\u0026channel=mmdede","type":"productName"}]} 

在这里，您可以找到"currentprice":"444.00"属性与价格。

• 通过投掷出一些可选参数简化的请求，事实证明，相同的JSON响应可以由URL http://www.mediamarkt.de/FACT-Finder/Suggest.ff?channel=mmdede&query=BOSCH+WTW+85230
• 即数据足以建立了一些代码，假设用于产品第一列被接收：

Option Explicit 

Sub TestMediaMarkt() 

    Dim oRange As Range 
    Dim aResult() As String 
    Dim i As Long 
    Dim sURL As String 
    Dim sRespText As String 

    ' set source range with product names from column A 
    Set oRange = ThisWorkbook.Worksheets(1).Range("A1:A3") 
    ' create one column array the same size 
    ReDim aResult(1 To oRange.Rows.Count, 1 To 1) 
    ' loop rows one by one, make XHR for each product 
    For i = 1 To oRange.Rows.Count 
     ' build up URL 
     sURL = "http://www.mediamarkt.de/FACT-Finder/Suggest.ff?channel=mmdede&query=" & EncodeUriComponent(oRange.Cells(i, 1).Value) 
     ' retrieve HTML content 
     With CreateObject("MSXML2.XMLHTTP") 
      .Open "GET", sURL, False 
      .Send 
      sRespText = .responseText 
     End With 
     ' regular expression for price property 
     With CreateObject("VBScript.RegExp") 
      .Global = True 
      .MultiLine = True 
      .IgnoreCase = True 
      .Pattern = """currentprice""\:""([\d.]+)""" ' capture digits after 'currentprice' in submatch 
      With .Execute(sRespText) 
       If .Count = 0 Then ' no matches, something going wrong 
        aResult(i, 1) = "N/A" 
       Else ' store the price to the array from the submatch 
        aResult(i, 1) = .Item(0).Submatches(0) 
       End If 
      End With 
     End With 
    Next 
    ' output resultion array to column B 
    Output Sheets(1).Range("B1"), aResult 

End Sub 

Function EncodeUriComponent(strText) 
    Static objHtmlfile As Object 
    If objHtmlfile Is Nothing Then 
     Set objHtmlfile = CreateObject("htmlfile") 
     objHtmlfile.parentWindow.execScript "function encode(s) {return encodeURIComponent(s)}", "jscript" 
    End If 
    EncodeUriComponent = objHtmlfile.parentWindow.encode(strText) 
End Function 

Sub Output(oDstRng As Range, aCells As Variant) 
    With oDstRng 
     .Parent.Select 
     With .Resize(_ 
      UBound(aCells, 1) - LBound(aCells, 1) + 1, _ 
      UBound(aCells, 2) - LBound(aCells, 2) + 1 _ 
     ) 
      .NumberFormat = "@" 
      .Value = aCells 
      .Columns.AutoFit 
     End With 
    End With 
End Sub 

• 填充工作表的一些产品名称：

• 推出子，并得到了结果：

这仅仅是如何从通过XHR的网站上的数据和解析响应的例子与RegExp，我希望它可以帮助。