來自DIV類的Web抓取欄位，VBA錯誤

我正在嘗試從網站制作一個 excel 資料表，我發現了這個 有用的例子，但是我收到了 VBA 錯誤。

我的代碼是：

Sub WebData()
  Dim http As New XMLHTTP60
  Dim html As New HTMLdocument
  Dim currentRow As Long
  
  currentRow = x 'Here your start row
  
  With http
    .Open "get", "https://www.careinspectorate.com/index.php/care-services?detail=CS2004081195", False
    .send
    html.body.innerHTML = .responseText
  End With
  
  Cells(currentRow, 1) = Trim(html.getElementsByClassName("service_manager")(0).innertext)
  currentRow = currentRow   1
  Cells(currentRow, 2) = Trim(html.getElementsByClassName("service_tel")(0).innertext)
End Sub

并且我收到錯誤“運行時錯誤‘91’物件變數或塊變數未設定。”我已向專案添加了 MS HTML 和 XML v6.0 參考。

一旦我開始基本匯入作業，我將添加更多欄位，然后在“CS ....”數字串列上運行此腳本。

任何幫助，將不勝感激

uj5u.com熱心網友回復：

正如 Tim Williams 在評論中所說，內容是動態加載的，因此您將無法使用 XMLHTTP 從 HTML 檔案中提取它。

因此，您可以做的是直接從 XHR 獲取內容 - 通過使用 DevTools 檢查網站，服務詳細資訊的 XHR 請求來自https://www.careinspectorate.com/templates/care-inspectorate/Apache/service_detail.php請求正文，service_number='CS2004081195'因此這就是您需要在代碼中復制的內容。

通常結果可以是任何形式（HTML、JSON、XML.. 等），但在這種情況下，我假設它作為~分隔文本回傳：

2004-11-16 00:00:00~Perth & Kinross Council - Adults with Learning Disabilities~Support services - care at home and housing support service combined~41d St Catherines Road~~~~Perth~PH1 5SJ~01738 477 637~~Shona Thompson~~~0~SP2003003370~Perth & Kinross Council~Active~56.399466738077300,-3.440588000000000~PH1 5SJ~Support Service~1

由于它只是一個字串，因此有很多方法可以決議資料，我選擇將它們拆分為陣列，然后通過索引檢索資料。

下面的完整代碼，這將獲得經理的姓名和電話，但顯然這是一個假設，您需要進行多次測驗以確認此方法有效：

Sub WebData()
  Const serviceNo As String = "CS2004081195"
  Const managerName As Long = 11
  Const managerTel As Long = 9
  
  Dim http As MSXML2.XMLHTTP60
  Set http = New MSXML2.XMLHTTP60
  
  Dim requestData As String
  requestData = "service_number='" & serviceNo & "'"
  
  With http
    .Open "POST", "https://www.careinspectorate.com/templates/care-inspectorate/Apache/service_detail.php", False
    .setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
    .send (requestData)
            
    Dim responseData As String
    responseData = .responseText
  End With
  
  Dim responseArr As Variant
  responseArr = Split(responseData, "~")
  
  Dim ws As Worksheet
  Set ws = ThisWorkbook.Worksheets("Sheet1") 'Change the name to the correct worksheet name
  
  Dim currentRow As Long
  currentRow = 2 'Here your start row
  
  ws.Cells(currentRow, 1) = Trim$(responseArr(managerName)) 'Always fully qualify your range or VBA will assume you are referring to the ActiveSheet which might not be what you want.
  ws.Cells(currentRow, 2) = Trim$(responseArr(managerTel))
  currentRow = currentRow   1
  
End Sub

uj5u.com熱心網友回復：

非常感謝您的回復，太好了！我沒有意識到資料是在頁面加載后進入的，這解釋了我在 HTML 中嘗試執行此操作時遇到的問題！

VBA 作業得很好，我只是使用以下完成的代碼提取了大約 12,000 行的所有欄位。可能有更有效的方法來對我添加/更改的部分進行編程，但它有效！

A 行有一個“serviceNo”串列，宏在幾分鐘內完成了所有內容。

 Sub WebData()
    
  'Const serviceNo As String = "CS2007142325"

  Const Field0 As Long = 0
  Const Field1 As Long = 1
  Const Field2 As Long = 2
  Const Field3 As Long = 3
  Const Field4 As Long = 4
  Const Field5 As Long = 5
  Const Field6 As Long = 6
  Const Field7 As Long = 7
  Const Field8 As Long = 8
  Const Field9 As Long = 9
  Const Field10 As Long = 10
  Const Field11 As Long = 11
  Const Field12 As Long = 12
  Const Field13 As Long = 13
  Const Field14 As Long = 14
  Const Field15 As Long = 15
  Const Field16 As Long = 16
  Const Field17 As Long = 17
  Const Field18 As Long = 18
  Const Field19 As Long = 19
  Const Field20 As Long = 20
  Const Field21 As Long = 21
  Const Field22 As Long = 22
  Const Field23 As Long = 23
  
  Dim currentRow As Long
  currentRow = 2 'Here your start row
  
  Dim cell As Range
    With Sheets("Sheet1")
        For Each cell In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
            serviceNo = cell.Value
            
  
  Dim http As MSXML2.XMLHTTP60
  Set http = New MSXML2.XMLHTTP60
  
  Dim requestData As String
  requestData = "service_number='" & serviceNo & "'"
  
  With http
    .Open "POST", "https://www.careinspectorate.com/templates/care-inspectorate/Apache/service_detail.php", False
    .setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
    .send (requestData)
            
    Dim responseData As String
    responseData = .responseText
  End With
  
  Dim responseArr As Variant
  responseArr = Split(responseData, "~")
  
  Dim ws As Worksheet
  Set ws = ThisWorkbook.Worksheets("Sheet1") 'Change the name to the correct worksheet name
  
  ws.Cells(currentRow, 2) = Trim$((serviceNo))
  ws.Cells(currentRow, 3) = Trim$(responseArr(Field0)) 'Always fully qualify your range or VBA will assume you are referring to the ActiveSheet which might not be what you want.
  ws.Cells(currentRow, 4) = Trim$(responseArr(Field1))
  ws.Cells(currentRow, 5) = Trim$(responseArr(Field2))
  ws.Cells(currentRow, 6) = Trim$(responseArr(Field3))
  ws.Cells(currentRow, 7) = Trim$(responseArr(Field4))
  ws.Cells(currentRow, 8) = Trim$(responseArr(Field5))
  ws.Cells(currentRow, 9) = Trim$(responseArr(Field6))
  ws.Cells(currentRow, 10) = Trim$(responseArr(Field7))
  ws.Cells(currentRow, 11) = Trim$(responseArr(Field8))
  ws.Cells(currentRow, 12) = Trim$(responseArr(Field9))
  ws.Cells(currentRow, 13) = Trim$(responseArr(Field10))
  ws.Cells(currentRow, 14) = Trim$(responseArr(Field11))
  ws.Cells(currentRow, 15) = Trim$(responseArr(Field12))
  ws.Cells(currentRow, 16) = Trim$(responseArr(Field13))
  ws.Cells(currentRow, 17) = Trim$(responseArr(Field14))
  ws.Cells(currentRow, 18) = Trim$(responseArr(Field15))
  ws.Cells(currentRow, 19) = Trim$(responseArr(Field16))
  ws.Cells(currentRow, 20) = Trim$(responseArr(Field17))
  ws.Cells(currentRow, 21) = Trim$(responseArr(Field18))
  ws.Cells(currentRow, 22) = Trim$(responseArr(Field19))
  ws.Cells(currentRow, 23) = Trim$(responseArr(Field20))
  ws.Cells(currentRow, 24) = Trim$(responseArr(Field21))
  
  currentRow = currentRow   1
  Next cell
  
  
End With
  
End Sub

標籤：html 擅长 vba 网页抓取

上一篇：將日期時間戳與今天的日期進行比較的Excel公式

下一篇：使用ExcelVBA-Selenium按“Enter”