json - VBA-Problemas de raspado de HTML

excel-vba web-scraping

Question

Estoy tratando de raspar los datos de la subasta de un sitio web https://www.rbauction.com/heavy-equipment-auctions . Mi intento actual fue usar el siguiente código para incorporar 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, número 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

Obtiene con éxito los datos, pero la sección ''próxima subasta de equipo pesado'' que tiene todos los nombres y tamaños de las subastas no se incluye en 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 se incluye en VBA, no se encuentran los artículos que quiero.

Answer 1

La fuente HTML de la página web mediante el enlace proporcionado 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 para desarrolladores ( F12 ), pestaña Red, vuelva a cargar ( F5 ) la página y examine los XHR registrados. Los datos más relevantes son la cadena JSON devuelta por la URL https://www.rbauction.com/rba-api/calendar/v1?e1=true :

Puede usar el siguiente código de VBA para recuperar información como se describe anteriormente. 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:

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