VBA – Problemas de raspado de HTML

Estoy intentando raspar datos de subastas de un sitio web https://www.rbauction.com/heavy-equipment-auctions . Mi bash actual era usar el siguiente código para pasar el HTML del sitio web a VBA y luego analizarlo y conservar solo los elementos que quería (nombre de la subasta, número de días, cantidad de elementos).

Sub RBA_Auction_Scrape() Dim S_Sheet As Worksheet Dim Look_String As String Dim Web_HTML As String Dim HTTP_OBJ As New MSXML2.XMLHTTP60 On Error GoTo ERR_LABEL: Set S_Sheet = ActiveWorkbook.ActiveSheet 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 End Sub 

Reúne con éxito los datos, pero la sección “próxima subasta de equipos pesados” que tiene todos los nombres y tamaños de las subastas no llega a VBA. No soy muy bueno con HTML en general, pero esperaba que alguien pudiera ofrecer una solución o al menos una explicación sobre cuándo busco en el sitio web HTML que está en VBA, los artículos que deseo no se encuentran.

La fuente HTML de la página web mediante el enlace provisto https://www.rbauction.com/heavy-equipment-auctions no contiene los datos necesarios, utiliza AJAX. El sitio web https://www.rbauction.com tiene una API disponible. La respuesta se devuelve en formato JSON. Navegue por la página, por ejemplo, en Chrome, luego abra la ventana Herramientas del desarrollador ( F12 ), pestaña Red, vuelva a cargar ( F5 ) la página y examine los XHR registrados. La mayoría de los datos relevantes son cadenas JSON devueltas por la URL https://www.rbauction.com/rba-api/calendar/v1?e1=true :

XHR-previev

Encabezados XHR

Puede usar el siguiente código de VBA para recuperar información como se describe arriba. Importe el módulo JSON.bas al proyecto VBA para el procesamiento 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 

La salida para mí es la siguiente:

salida

Por cierto, el mismo enfoque aplicado en las siguientes respuestas: 1 , 2 , 3 , 4 , 5 , 6 y 7 .