在特定單元格中導入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，我希望它可以幫助。