Ошибка «Слишком большая процедура VBA» при импорте данных HTML - PullRequest
1 голос
/ 08 января 2020

У меня есть код для импорта HTML данных с веб-сайта.

Он работает для импорта данных до 94 строк Excel. После этого выдается ошибка

Слишком большая процедура VBA.

Я повторяю код, начинающийся с ieApp.Navigate "https://icms.indianrail.gov.in/reports/ReportServlet?reportAction=Utility&reportType=LocoCurrStatus&subAction=main до End If для каждой строки.

Как мне изменить код для более чем 600 строк? Sub GetTable ()

Dim ieApp As InternetExplorer
Dim ieDoc As Object
Dim ieTable As Object
Dim clip As DataObject

'create a new instance of ie
Set ieApp = New InternetExplorer

'you don’t need this, but it’s good for debugging
ieApp.Visible = True

'assume we’re not logged in and just go directly to the login page
ieApp.Navigate "https://icms.indianrail.gov.in/reports/"
Do While ieApp.Busy: DoEvents: Loop
Do Until ieApp.ReadyState = READYSTATE_COMPLETE: DoEvents: Loop

Set ieDoc = ieApp.Document
'fill in the login form – View Source from your browser to get the control names
With ieDoc.forms(0)
    .UserId.Value = "88888"
    .Password.Value = "******"
    .submit
End With
Do While ieApp.Busy: DoEvents: Loop
Do Until ieApp.ReadyState = READYSTATE_COMPLETE: DoEvents: Loop

'now that we’re in, go to the page we want
ieApp.Navigate "https://icms.indianrail.gov.in/reports/ReportServlet? 
reportAction=Utility&reportType=LocoCurrStatus&subAction=main"
Do While ieApp.Busy: DoEvents: Loop
Do Until ieApp.ReadyState = READYSTATE_COMPLETE: DoEvents: Loop

'get the table based on the table’s id
Set ieDoc = ieApp.Document
With ieDoc.forms(0)
    .trainNo.Value = Sheets("sheet1").Range("B2").Value
    .startDate.Value = Format(Date - 1, "dd-mmm-yyyy")
    .submit
End With
Do While ieApp.Busy: DoEvents: Loop
Do Until ieApp.ReadyState = READYSTATE_COMPLETE: DoEvents: Loop

Set ieDoc = ieApp.Document
Set ieTable = ieDoc.all.Item("TABLE_6")

'copy the tables html to the clipboard and paste to teh sheet
If Not ieTable Is Nothing Then
    Set clip = New DataObject
    clip.SetText "" & ieTable.outerHTML & ""
    clip.PutInClipboard
    Sheet1.Select
    Sheet1.Range("D2").Select
    Sheet1.PasteSpecial "Unicode Text"
End If
End Sub

Мой лист Excel:
My Excel Sheet

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