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로 끌어 올려 진 웹 사이트 HTML을 검색 할 때 적어도 내가 원하는 기사를 찾을 수 없기를 바랄 수 있었다.

도와주세요!

Answer 1

제공된 웹 페이지의 소스 코드 https://www.rbauction.com/heavy-equipment-auctions에는 필요한 데이터가 없으므로 AJAX가 사용됩니다. 웹 사이트 https://www.rbauction.com에는 사용 가능한 API가 있습니다. 응답은 JSON 형식으로 반환됩니다. 페이지 탐색 e. 지. Chrome에서 개발자 도구 창 (F12), 네트워크 탭을 열고 페이지를 다시로드하고 기록 된 XHR을 검사합니다.

당신은 전술 한 바와 같이 정보를 검색하는 VBA 코드 아래를 사용할 수있다 : 대부분의 관련 데이터는 URL https://www.rbauction.com/rba-api/calendar/v1?e1=true에 의해 반환 된 JSON 문자열입니다. JSON.bas 모듈을 JSON 처리를 위해 VBA 프로젝트로 가져 오십시오. 다음

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 

날의 출력은 :

BTW 같은 접근법은 다음 응답에 적용 : 1, 2, 3, 4, 5, 6 및 7.