XHTML Website掻き取り指導

Question

私はVBAとHTML/XHTMLの新機能ですが、オンラインでの調査や他のすばらしいメンバーの助けを借りて、私が望むデータを引き出すコードを書くことができました。それがXHTMLであるので、私が欲しい要素のIDを特定するのは苦労していたので、私はそれを最も嫌っていたと思う。

ウェブサイト：http://www.usbanklocations.com/banks.php?q=&ct=&ml=30&lc=

ここで私はコードが何をしたいです： は銀行名、住所、電話番号、預金合計と総資産を引いて - 銀行名、市特定のIは、私の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

代わりにIEとスプリットベースのHTMLコンテンツの解析のXHRを使用する例下記考えてみましょう。例として

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 

、最初のワークシートを絞り込むために（銀行名、場所との距離を検索するためのデータが含まれています）：

第2のワークシートに生じる次の通りである：