XHTML Website Scraping Guidance

Question

Я очень новичок в VBA и HTML/XHTML, но через онлайн-исследование и помощь других замечательных членов здесь мне удалось написать код, чтобы вытащить нужные данные. Мне было трудно идентифицировать идентификаторы элементов, которые я хочу, так как они находятся в XHTML, поэтому я думаю, что именно там я его больше всего испортил.

Сайт:http://www.usbanklocations.com/banks.php?q=&ct=&ml=30&lc=

Вот что я хочу код, чтобы сделать: Вытащите банка имя, адрес, номер телефона, общая сумма депозитов и Всего активов - давший название банка и город, который я укажите в моем листе excel.

Вот мой код:

Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long) 
Sub CommunityBanks() 
    Dim IE As Object, TableResults As Object, webRow As Object, BankName As Variant, page As Long, pageTotal As Long, r As Long 
    Dim beginTime As Date, i As Long, myvalue As Variant 

Set IE = CreateObject("internetexplorer.application") 
IE.navigate "http://www.usbanklocations.com/banks.php?name=" & Range("A2").Value & "+Bank&ml=30&lc=" & Range("B2").Value & "%2C+TX" 
IE.Visible = True 

Do While IE.Busy Or IE.readystate <> 4 '4 = READYSTATE_COMPLETE 
    DoEvents 
Loop 

'input bank name into form 
'myvalue = InputBox("Enter City. Press okay to begin search", "Bank Search") 
'Range("F3").Value = myvalue 
'IE.document.getelementbyid("MainContent_txtCity").Value = "LegacyTexas" 
'click find button 
'IE.document.getelementbyid("MainContent_btn").Click 
'Sleep 5 * 1000 
IE.document.getelementbytagname("table").getelementsbyclassname("btn").Click 
Sleep 5 * 1000 

'total pages 
pageTotal = IE.document.getelementbyid("lsortby").innertext 
page = 0 

Do Until page = pageTotal 
    DoEvents 
    page = IE.document.getelementbyclassname("lsortby").innertext 
    With IE.document.getelementbyid("main") 
     For r = 1 To .Rows.Length - 1 
      If Not IsArray(BankName) Then 
       ReDim BankName(7, 0) As Variant 
      Else 
       ReDim Preserve BankName(7, UBound(BankName, 2) + 1) As Variant 
      End If 

      BankName(0, UBound(BankName, 2)) = .Rows(r).Cells(0).innertext 
     Next r 
    End With 

    If page < pageTotal Then 
     IE.document.getelementbyclassname("panelpn").Click 
     beginTime = Now 
     Application.Wait (Now + TimeValue("00:00:05")) 
    End If 
Loop 

For r = 0 To UBound(BankName, 2) 
    IE.navigate "http://www.usbanklocations.com/" & BankName(0, r) 
    Do While IE.Busy Or IE.readystate <> 4 '4 = READYSTATE_COMPLETE 
     DoEvents 
    Loop 
    'wait 5 sec. for screen refresh 
    Sleep 5 * 1000 

    With IE.document.getelementbytagname("table") 
     For i = 0 To .Rows.Length - 1 
      DoEvents 
      Select Case .Rows(i).Cells(0).innertext 
      Case "Name:" 
       BankName(1, r) = .Rows(i).Cells(1).innertext 
      Case "Location:" 
       BankName(2, r) = .Rows(i).Cells(1).innertext 
      Case "Phone:" 
       BankName(3, r) = .Rows(i).Cells(1).innertext 
      Case "Branch Deposit:" 
       BankName(4, r) = Replace(Replace(.Rows(i).Cells(1).innertext, ",", ""), "$", "") 
      Case "Total Assets:" 
       BankName(5, r) = Replace(Replace(.Rows(i).Cells(1).innertext, ",", ""), "$", "") 
      End Select 
     Next i 
    End With 
Next r 


IE.Quit 
Set IE = Nothing 

'post result on Excel cell 
Worksheets(1).Range("A9").Resize(UBound(BankName, 2) + 1, UBound(BankName, 1) + 1).Value = Application.Transpose(BankName) 
End Sub 

Спасибо заранее! Я был бы очень признателен за любую помощь.

Answer 1

Рассмотрим следующий пример, который использует XHR вместо IE и разделения на основе содержимого HTML разборе:

Option Explicit 

Sub Test_usbanklocations() 

    Dim oSource, oDestination, y, oSrcRow, sName, sCity, sDist, sUrl0, sUrl1, sUrl2, lPage, sResp1, sResp2, i, a1, a2, a3, a4, a5 

    Set oSource = Sheets(1) 
    Set oDestination = Sheets(2) 
    oDestination.Cells.Delete 
    DataOutput oDestination, 1, Array("Name", "Location", "Phone", "Total Assets", "Total Deposits") 
    y = 2 

    For Each oSrcRow In oSource.UsedRange.Rows 
     sName = oSrcRow.Cells(1, 1).Value 
     sCity = oSrcRow.Cells(1, 2).Value 
     sDist = oSrcRow.Cells(1, 3).Value 
     sUrl0 = "http://www.usbanklocations.com/banks.php?q=" & EncodeUriComponent(sName) & "&lc=" & EncodeUriComponent(sCity) & "&ml=" & sDist 
     sUrl1 = sUrl0 
     lPage = 1 
     Do 
      sResp1 = GetXHR(sUrl1) 
      If InStr(sResp1, "We can not find the address you provided. Please check.") > 0 Then Exit Do 
      a1 = Split(sResp1, "<div class=""pl") 
      For i = 1 To UBound(a1) 
       a2 = Split(a1(i), "</div>", 3) 
       a3 = Split(a2(1), "<a href=""", 2) 
       a4 = Split(a3(1), """>", 2) 
       sUrl2 = "http://www.usbanklocations.com" & a4(0) 
       sResp2 = GetXHR(sUrl2) 
       a5 = Array(_ 
        GetFragment(sResp2, "<b>Name:</b></td><td>", "</td>"), _ 
        Replace(GetFragment(sResp2, "<b>Location:</b></td><td>", "</td>"), "View Other Branches", ""), _ 
        GetFragment(sResp2, "<b>Phone:</b></td>", "</td>"), _ 
        GetFragment(sResp2, "<b>Total Assets:</b></td><td>", "</td>"), _ 
        GetFragment(sResp2, "<b>Total Deposits:</b></td><td>", "</td>") _ 
       ) 
       DataOutput oDestination, y, a5 
       y = y + 1 
       DoEvents 
      Next 
      If InStr(sResp1, "Next Page &gt;") = 0 Then Exit Do 
      lPage = lPage + 1 
      sUrl1 = sUrl0 & "&ps=" & lPage 
      DoEvents 
     Loop 
    Next 

    MsgBox "Completed" 

End Sub 

Function GetXHR(sUrl) 

    With CreateObject("MSXML2.XMLHTTP") 
     .Open "GET", sUrl, False 
     .Send 
     GetXHR = .ResponseText 
    End With 

End Function 

Sub DataOutput(oSht, y, aValues) 

    With oSht.Cells(y, 1).Resize(1, UBound(aValues) + 1) 
     .NumberFormat = "@" 
     .Value = aValues 
    End With 

End Sub 

Function GetFragment(sText, sPatt1, sPatt2) 

    Dim a1, a2 

    a1 = Split(sText, sPatt1, 2) 
    If UBound(a1) <> 1 Then Exit Function 
    a2 = Split(a1(1), sPatt2, 2) 
    If UBound(a2) <> 1 Then Exit Function 
    GetFragment = GetInnerText(a2(0)) 

End Function 

Function EncodeUriComponent(sText) 

    Static objHtmlfile As Object 

    If objHtmlfile Is Nothing Then 
     Set objHtmlfile = CreateObject("htmlfile") 
     objHtmlfile.parentWindow.execScript "function encode(s) {return encodeURIComponent(s)}", "jscript" 
    End If 
    EncodeUriComponent = objHtmlfile.parentWindow.encode(sText) 

End Function 

Function GetInnerText(sText) 

    With CreateObject("htmlfile") 
     .Write ("<body>" & sText & "</body>") 
     GetInnerText = .DocumentElement.Document.GetElementsByTagName("body")(0).InnerText 
    End With 

End Function 

В качестве примера, первый лист содержит данные для поиска (банк имя, местоположение и расстояние для уточнения по):

Затем результат на втором листе выглядит следующим образом: