VBA - HTMLスクレイピングの問題

Question

ウェブサイト（https://www.rbauction.com/heavy-equipment-auctions）からオークションデータを削り取ろうとしています。私の現在の試みは、以下のコードを使ってウェブサイトのHTMLをVBAに変換し、それをスパースして、必要なアイテム（オークション名、日数、アイテム数）のみを保持することでした。

Sub RBA_Auction_Scrape() 

Dim S_Sheet As Worksheet: Set S_Sheet = ActiveWorkbook.ActiveSheet 
Dim Look_String As String 

On Error GoTo ERR_LABEL: 

Dim Web_HTML As String 
Dim HTTP_OBJ As New MSXML2.XMLHTTP60 

    Web_HTML = "" 
    HTTP_OBJ.Open "GET", "https://www.rbauction.com/heavy-equipment auctions", False 
    HTTP_OBJ.Send 

On Error Resume Next 

Select Case HTTP_OBJ.Status 
    Case 0: Web_HTML = HTTP_OBJ.responseText 
    Case 200: Web_HTML = HTTP_OBJ.responseText 
    Case Else: GoTo ERR_LABEL: 
End Select 

Debug.Print (Web_HTML) 

それは成功したデータに引っ張るが、オークションの名前とサイズのすべてを持っている「今後の重機オークション」セクションには、VBAに引き込まれません。私は一般的にはHTMLにはあまりよくないが、誰かが解決策を提供したり、少なくともVBAに取り込まれたWebサイトのHTMLを検索して、必要な記事が見つからないことを願っていた。

助けてください！

Answer 1

提供されたリンクによるWebページソースのHTML https://www.rbauction.com/heavy-equipment-auctionsには、必要なデータが含まれていないため、AJAXが使用されています。ウェブサイトhttps://www.rbauction.comには、利用可能なAPIがあります。レスポンスはJSON形式で返されます。ページをナビゲートします。e。 g。 Chromeの場合、[開発ツール]ウィンドウ（F12）、[ネットワーク]タブを開き、ページをリロードしてログに記録されたXHRを調べます。最も関連性の高いデータは、URL https://www.rbauction.com/rba-api/calendar/v1?e1=trueで返されるJSON文字列です：

上記のようにあなたが情報を取得するために、VBAコードの下に使用することができます。 JSON.basモジュールをVBAプロジェクトにインポートしてJSON処理を行います。次のように

Option Explicit 

Sub Test_www_rbauction_com() 

    Const Transposed = False ' Output option 

    Dim sResponse As String 
    Dim vJSON 
    Dim sState As String 
    Dim i As Long 
    Dim aRows() 
    Dim aHeader() 

    ' Retrieve JSON data 
    XmlHttpRequest "GET", "https://www.rbauction.com/rba-api/calendar/v1?e1=true", "", "", "", sResponse 
    ' Parse JSON response 
    JSON.Parse sResponse, vJSON, sState 
    If sState <> "Object" Then 
     MsgBox "Invalid JSON response" 
     Exit Sub 
    End If 
    ' Pick core data 
    vJSON = vJSON("auctions") 
    ' Extract selected properties for each item 
    For i = 0 To UBound(vJSON) 
     Set vJSON(i) = ExtractKeys(vJSON(i), Array("eventId", "name", "date", "itemCount")) 
     DoEvents 
    Next 
    ' Convert JSON structure to 2-d arrays for output 
    JSON.ToArray vJSON, aRows, aHeader 
    ' Output 
    With ThisWorkbook.Sheets(1) 
     .Cells.Delete 
     If Transposed Then 
      Output2DArray .Cells(1, 1), WorksheetFunction.Transpose(aHeader) 
      Output2DArray .Cells(1, 2), WorksheetFunction.Transpose(aRows) 
     Else 
      OutputArray .Cells(1, 1), aHeader 
      Output2DArray .Cells(2, 1), aRows 
     End If 
     .Columns.AutoFit 
    End With 
    MsgBox "Completed" 

End Sub 

Sub XmlHttpRequest(sMethod As String, sUrl As String, arrSetHeaders, sFormData, sRespHeaders As String, sContent As String) 

    Dim arrHeader 

    'With CreateObject("Msxml2.ServerXMLHTTP") 
    ' .SetOption 2, 13056 ' SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS 
    With CreateObject("MSXML2.XMLHTTP") 
     .Open sMethod, sUrl, False 
     If IsArray(arrSetHeaders) Then 
      For Each arrHeader In arrSetHeaders 
       .SetRequestHeader arrHeader(0), arrHeader(1) 
      Next 
     End If 
     .send sFormData 
     sRespHeaders = .GetAllResponseHeaders 
     sContent = .responseText 
    End With 

End Sub 

Function ExtractKeys(oSource, aKeys, Optional oDest = Nothing) As Object 

    Dim vKey 

    If oDest Is Nothing Then Set oDest = CreateObject("Scripting.Dictionary") 
    For Each vKey In aKeys 
     If oSource.Exists(vKey) Then 
      If IsObject(oSource(vKey)) Then 
       Set oDest(vKey) = oSource(vKey) 
      Else 
       oDest(vKey) = oSource(vKey) 
      End If 
     End If 
    Next 
    Set ExtractKeys = oDest 

End Function 

Sub OutputArray(oDstRng As Range, aCells As Variant) 

    With oDstRng 
     .Parent.Select 
     With .Resize(1, UBound(aCells) - LBound(aCells) + 1) 
      .NumberFormat = "@" 
      .Value = aCells 
     End With 
    End With 

End Sub 

Sub Output2DArray(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 
     End With 
    End With 

End Sub 

私のための出力は、次のとおりです。

ところで、同じアプローチは、以下の回答で適用：1、2、3、4、5、6と7。