Веб соскоб таблицы в VBA - PullRequest
Новая
       1

Веб соскоб таблицы в VBA

1 голос
/ 24 апреля 2020

Я успешно перешел на страницу с таблицей, с которой я буду sh извлекать данные. Позвольте мне быть искренним с самого начала, это первый раз, когда я пытаюсь что-то подобное, и я действительно доволен собой за то, что зашел так далеко. Я перешел на нужную веб-страницу, обновил имя пользователя, пароль, а затем перешел на страницу, содержащую интересующую меня таблицу.

Я сейчас пытаюсь извлечь данные из таблицы и получаю следующее ошибка, см. ниже:

enter image description here

Мой код выглядит следующим образом: 

'==============================================================
'
Public IE                   As New SHDocVw.InternetExplorer
'==============================================================
'                           HTML DOCUMENT
'
Public HTMLDoc              As MSHTML.HTMLDocument
'==============================================================
'                           BUTTON COLLECTION
'
Public HTMLButtons          As MSHTML.IHTMLElementCollection
Public HTMLButton           As MSHTML.IHTMLElement
'==============================================================
'                           ATTRIBUTE COLLECTION
'
Public HTMLAs               As MSHTML.IHTMLElementCollection3
Public HTMLA                As MSHTML.IHTMLElement3
'==============================================================
'                           TABLE COLLECTION
'
Public HTMLTables           As MSHTML.IHTMLElementCollection
Public HTMLTable            As MSHTML.IHTMLElement
'==============================================================
'                           TABLE ELEMENTS
'
Public TableBody            As MSHTML.IHTMLElementCollection2
Public TableRows            As MSHTML.IHTMLElementCollection3
Public TableCell            As MSHTML.IHTMLElementCollection4
'==============================================================
Public RowNum               As Long
Public ColNum               As Long
'==============================================================
'
'
Public Sub TableCollection()

Worksheets.Add
RowNum = 1
Set TableBody = HTMLDoc.getElementsByTagName("tbody")
Set TableRows = HTMLDoc.getElementsByTagName("tr")
Set TableCell = HTMLDoc.getElementsByTagName("td")
For Each TableRows In TableBody
    ColNum = 1
    For Each TableCell In TableRows
        Cells(RowNum, ColNum).Value = TableCell.innerText
        ColNum = ColNum + 1
    Next TableCell
RowNum = RowNum + 1
Next TableRows
End Sub

"======== ================================================== ===========

А ниже приведен заголовок и один элемент таблицы, которую я пытаюсь очистить. Я заменил URL-адрес на WEBADDRESS 

<html><head>
  <title>
    Transaction SpreadSheet for the Current Month to date - April 2020</title>
</head>
<body>
<style>
  td { font-family:arial,verdana,sans-serif;font-size:12px;color:#000000;line-height:16px;}
</style>
<table cellpadding="2">
  <tbody>
  <tr>
    <td>
      <b>Date</b>
    </td>
    <td>
      <b>Reference</b>
    </td>
        <td>
      <b>Item</b>
    </td>
    <td>
      <b>Particulars</b>
    </td>
    <td>
      <b>Buyer</b>
    </td>
        <td>
      <b>Order Id</b>
    </td>
    <td>
      <b>Note</b>
    </td>
    <td>
      <b>Transaction Amount</b>
    </td>
   </tr>
<tr>
  <td>
    04&nbsp;Apr&nbsp;2020</td>
    <td>
    239137532</td>  
  <td>
    <a href="https://WEBADDRESS">461619577</a></td>
  <td>
    Success Fee</td>
  <td>
  <a title="User profile for Joe" href="WEBADDRESS">RoySch2510</a>
  </td>
    <td>
  <a href="https://WEBADDRESS" rel="nofollow,noindex">17314294</a>
  </td>
  <td>
    </td>   
  <td>
    -62.55</td>
  </tr>
<tr>

Пожалуйста, посоветуйте, что я делаю не так

ОК. Вот весь мой код, надеюсь, он даст больше понимания: 

Option Explicit

Public Sub GetHTMLDocument()
'===========================================================================
'                         ESTABLISH PUBLIC VARIABLES
'
Call PublicHTMLVariables
'===========================================================================
'                              NAVIGATE TO IE
'
Call NavigateToIE("https://old.bidorbuy.co.za/jsp/login/UserLogin.jsp")
'===========================================================================
'                                   LOGIN
'
Call LoginToWebsite("JoeCam9517", "********")
'===========================================================================
'                           NAVIGATE TO 1st PAGE
'
Call NavigateToFirstPage
'===========================================================================
'                      NAVIGATE TO ACCOUNT HISTORY PAGE
'
Call NavigateToAccountsPage
'===========================================================================
'               CHANGE THE DATE RANGE FOR TRANSACTION SELECTION
'
'Call ChangeDateRange
'===========================================================================
'                      NAVIGATE TO ACCOUNT TABLE PAGE
'
Call NavigateToTablesPage
'===========================================================================
'                     COLLECT TABLE ELEMENTS TO WORKSHEET
'
Call TableCollection
'===========================================================================

MsgBox "Pause"
'                       MORE CODE STILL TO BE DEVELOPED

End Sub

ПУБЛИ C ПЕРЕМЕННЫЕ 

Option Explicit
'==============================================================
'
Public IE                   As New SHDocVw.InternetExplorer
'==============================================================
'                           HTML DOCUMENT
'
Public HTMLDoc              As MSHTML.HTMLDocument
'==============================================================
'                           HTML ELEMENTS
'
Public HTMLInput            As MSHTML.IHTMLElement
Public FromDay              As MSHTML.IHTMLElement
Public FromYearMonth        As MSHTML.IHTMLElement
Public ToDay                As MSHTML.IHTMLElement
'==============================================================
'                           BUTTON COLLECTION
'
Public HTMLButtons          As MSHTML.IHTMLElementCollection
Public HTMLButton           As MSHTML.IHTMLElement
'==============================================================
'                           ATTRIBUTE COLLECTION
'
Public HTMLAs               As MSHTML.IHTMLElementCollection3
Public HTMLA                As MSHTML.IHTMLElement3
'==============================================================
'                           TABLE COLLECTION
'
Public HTMLTable            As MSHTML.IHTMLElement
Public HTMLTableRows        As MSHTML.IHTMLElementCollection
Public HTMLTableCells       As MSHTML.IHTMLElementCollection
'==============================================================
'                           DATE ELEMENTS
'
Public ToYearMonth          As MSHTML.IHTMLElement
'==============================================================
'                           TABLE ELEMENTS
'
'Public TableBody            As MSHTML.IHTMLElementCollection2
'Public TableRows            As MSHTML.IHTMLElementCollection3
'Public TableCell            As MSHTML.IHTMLElementCollection4
'==============================================================
Public H                    As Integer
Public RowNum               As Long
Public ColNum               As Long
'==============================================================

Public Sub PublicHTMLVariables()

End Sub

Перейдите на веб-страницу 

Option Explicit

Public Sub NavigateToIE(Destination As String)
IE.Visible = True
IE.Navigate Destination
Do Until IE.ReadyState = 4
    DoEvents
Loop
End Sub

ПОДГОТОВЬТЕСЬ К ЛОГИНУ 

Option Explicit
Public Sub LoginToWebsite(UserID As String, PassWord As String)
Set HTMLDoc = IE.Document
Set HTMLInput = HTMLDoc.getElementById("username")
    HTMLInput.Value = UserID
Set HTMLInput = HTMLDoc.getElementById("password")
    HTMLInput.Value = PassWord
End Sub

НАВИГАЦИЯ К ПЕРВОЙ СТРАНИЦЕ 

Option Explicit
'===========================================================================
'
'
Public Sub NavigateToFirstPage()
Set HTMLButtons = HTMLdoc.getElementsByTagName("button")
HTMLButtons(3).Click
Do While IE.ReadyState = 4: DoEvents: Loop
Do Until IE.ReadyState = 4: DoEvents: Loop
End Sub

НАВИГАЦИЯ К СТРАНИЦЕ ИСТОРИИ СЧЕТА 

Option Explicit

'===========================================================================
'                      NAVIGATE TO ACCOUNT HISTORY PAGE
'
Public Sub NavigateToAccountsPage()
H = 0
Set HTMLAs = HTMLdoc.getElementsByTagName("a")
For Each HTMLA In HTMLAs
    If HTMLA.href = "https://old.bidorbuy.co.za/jsp/fee/UserAccount.jsp" Then
        GoTo ButtonFound
    End If
    H = H + 1
Next HTMLA
ButtonFound:
HTMLAs(H).Click
Do While IE.ReadyState = 4: DoEvents: Loop
Do Until IE.ReadyState = 4: DoEvents: Loop
End Sub

ИЗМЕНИТЬ ДИАПАЗОН ДАТЫ - НЕ РАБОТАЕТ - Я собираюсь попросить ПОМОЩЬ, ЧТО В ПОЗЖЕ ДАТА

НАВИГАЦИЯ К ТАБЛИЦАМ СТРАНИЦА 

Option Explicit


'=========================================================================
'
'                      NAVIGATE TO ACCOUNT TABLE PAGE
'
Public Sub NavigateToTablesPage()
Set HTMLButtons = HTMLdoc.getElementsByName("DetailSubmit")
HTMLButtons(1).Click
End Sub

И ТО, ЧТО ПРИНОСИТ НАС К ПРОЦЕДУРЕ У меня ПРОБЛЕМА С 

Option Explicit
'===========================================================================
'
'
Public Sub TableCollection()
Worksheets.Add

Dim HTMLdoc         As New HTMLDocument
Dim trow            As Object
Dim tcel            As Object
Dim rowNum          As Long
Dim colNum          As Long

rowNum = 1

For Each trow In HTMLdoc.getElementsByTagName("tbody")(0).getElementsByTagName("tr")
    colNum = 1
    For Each tcel In trow.getElementsByTagName("td")
        Cells(rowNum, colNum).Value = tcel.innerText
        colNum = colNum + 1
    Next tcel
    rowNum = rowNum + 1
Next trow
End Sub

'Set HTMLTable = HTMLDoc.getElementsByTagName("body")
'Set HTMLTableRows = HTMLdoc.getElementsByTagName("tr")
'Set HTMLTableCells = HTMLdoc.getElementsByTagName("td")
'For Each HTMLTableCells In HTMLTableRows
'Debug.Print HTMLTableRows.innerText
'Next HTMLTableCells
'    ColNum = 1
'    For Each TableCell In TableRows
'        Cells(RowNum, ColNum).Value = TableCell.innerText
'        ColNum = ColNum + 1
'    Next TableCell
'RowNum = RowNum + 1
'Next TableRows

Я знаю, что это чей-то другой код для просмотра, но я стараюсь написать мой код с видом, что кто-то еще может его редактировать. Кроме того, я прошу прощения за то, что я не следую обычному соглашению, но меня радует, когда я вижу переменную, начинающуюся с буквы в нижнем регистре, а затем на полпути через нее вы получаете заглавную букву, это просто не выглядит элегантно, извините :-)

Я начинаю подозревать, что проблема в том, как устроен стол, это возможно?

Я хочу сказать спасибо всем, кто пытался решить мою проблему. проблема, но я все еще застрял с тем же результатом. Используя приведенный выше код, я попадаю в эту таблицу: HTMLTable И затем я получаю эту ошибку. HTMLError

Как вы увидите из закомментированного кода, я пробовал несколько различных вариантов кодирования, но я просто продолжаю получать сообщение об ошибке.

Ответы [ 2 ]

0 голосов
/ 24 апреля 2020

Сохраняя вашу текущую попытку почти точной, вы можете сделать следующее, чтобы получить требуемые результаты. Если вы используете IE и у вас возникают проблемы со сбором данных, не забудьте указать задержку Application.Wait Now + TimeValue("00:00:05") для того, чтобы элемент был доступен. 

Dim HTMLdoc As New HTMLDocument
Dim trow As Object, tcel As Object
Dim rowNum As Long, colNum As Long

rowNum = 1
For Each trow In HTMLdoc.getElementsByTagName("tbody")(0).getElementsByTagName("tr")
    colNum = 1
    For Each tcel In trow.getElementsByTagName("td")
        Cells(rowNum, colNum).Value = tcel.innerText
        colNum = colNum + 1
    Next tcel
    rowNum = rowNum + 1
Next trow

Поскольку вы не указали URL-адрес сайта, Мне пришлось использовать ссылку в скрипте, чтобы убедиться, что он работает правильно. Вот рабочие сценарии.

Использование xhr: 

Sub FetchTabularData()
    Dim HTMLdoc As New HTMLDocument
    Dim trow As Object, tcel As Object
    Dim rowNum As Long, colNum As Long

    With CreateObject("WinHttp.WinHttpRequest.5.1")
        .Open "GET", "http://www.basketball-reference.com/players/a/", False
        .setRequestHeader "User-Agent", "Mozilla/5.0"
        .send
        HTMLdoc.body.innerHTML = .responseText
    End With

    rowNum = 1
    For Each trow In HTMLdoc.getElementsByTagName("tbody")(0).getElementsByTagName("tr")
        colNum = 1
        For Each tcel In trow.getElementsByTagName("td")
            Cells(rowNum, colNum).Value = tcel.innerText
            colNum = colNum + 1
        Next tcel
        rowNum = rowNum + 1
    Next trow
End Sub

IE реализация: 

Sub FetchTabularData()
    Dim trow As Object, tcel As Object
    Dim rowNum As Long, colNum As Long

    With CreateObject("InternetExplorer.Application")
        .Visible = True
        .navigate "http://www.basketball-reference.com/players/a/"
        While .Busy Or .readyState < 4: DoEvents: Wend
        Application.Wait Now + TimeValue("00:00:05")

        rowNum = 1
        For Each trow In .document.getElementsByTagName("tbody")(0).getElementsByTagName("tr")
            colNum = 1
            For Each tcel In trow.getElementsByTagName("td")
                Cells(rowNum, colNum).Value = tcel.innerText
                colNum = colNum + 1
            Next tcel
            rowNum = rowNum + 1
        Next trow
        .Quit
    End With
End Sub

Если он по-прежнему не может извлечь содержимое, есть возможность того, что стол находится в пределах фрейма чего-либо.

0 голосов
/ 24 апреля 2020

Я написал некоторую функцию для чтения любой таблицы HTML. Попробуйте использовать это. Разумеется, HTMLTab в качестве аргумента функции должен быть объектом HTMLTable / IHTMLTable. :) 

Function ReadTable(HTMLTab) As Variant
Dim myTable() As Variant

  rLen = HTMLTab.Rows.Length
  CLen = HTMLTab.Cells.Length / rLen
  ReDim myTable(0 To rLen - 1, 0 To CLen - 1)

  For Each myRow In HTMLTab.Rows
    j = 0
    For Each myCell In myRow.Cells
      myTable(i, j) = myCell.outerText
      j = j + 1
    Next myCell
    i = i + 1
  Next myRow

  ReadTable = myTable

End Function
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Нет похожих вопросов

...