VBA - HTML-Scraping-Probleme

Question

Ich versuche, Auktionsdaten von einer Website (https://www.rbauction.com/heavy-equipment-auctions) zu kratzen. Mein derzeitiger Versuch war es, den HTML-Code der Website in VBA zu kopieren und dann durchzuspähen und nur die gewünschten Elemente zu behalten (Name der Auktion, Anzahl der Tage, Anzahl der Elemente).

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) 

Es zieht erfolgreich in den Daten, aber die ‚bevorstehende schwere Ausrüstung Auktion‘ Abschnitt, der alle Namen und Größen der Auktionen hat nicht in VBA gezogen bekommen. Ich bin nicht sehr gut mit HTML im Allgemeinen, aber ich hoffte, dass jemand eine Lösung oder mindestens eine Erklärung anbieten könnte, wenn ich den HTML-Aufstellungsort suche, der in VBA gezogen wird, die Artikel, die ich will, werden nicht gefunden.

Bitte helfen Sie !!!

Answer 1

Die HTML-Seite der Webseite mit dem angegebenen Link https://www.rbauction.com/heavy-equipment-auctions enthält nicht die notwendigen Daten, sie verwendet AJAX. Die Webseite https://www.rbauction.com hat eine API zur Verfügung. Die Antwort wird im JSON-Format zurückgegeben. Navigieren Sie zur Seite e. G. Öffnen Sie in Chrome das Developer Tools-Fenster (F12), Registerkarte Netzwerk, laden Sie die Seite neu und überprüfen Sie die protokollierten XHRs (F5). Die meisten relevanten Daten ist JSON-String in der URL zurückgegeben https://www.rbauction.com/rba-api/calendar/v1?e1=true:

Sie die folgenden VBA-Code verwenden können Informationen abgerufen werden, wie oben beschrieben. Importieren Sie das Modul JSON.bas in das VBA-Projekt für die JSON-Verarbeitung.

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 

Der Ausgang ist für mich wie folgt:

BTW, der gleiche Ansatz in den folgenden Antworten angewendet: 1, 2, 3, 4, 5, 6 und 7.