Как импортировать данные с нескольких страниц?

Question

У меня есть небольшой фрагмент кода, в котором перечислены ссылки на сайте.

Sub ListLinks() 

'Set a reference to microsoft Internet Controls 
Dim IeApp As InternetExplorer 
Dim sURL As String 
Dim IeDoc As Object 
Dim i As Long 

Set IeApp = New InternetExplorer 

IeApp.Visible = True 

sURL = "http://www.sharenet.co.za/v3/q_sharelookup.php" 

IeApp.Navigate sURL 

Do 
Loop Until IeApp.ReadyState = READYSTATE_COMPLETE 
Set IeDoc = IeApp.Document 

For i = 0 To IeDoc.Links.Length - 1 
    Cells(i + 1, 1).Value = IeDoc.Links(i).href 
Next i 

Set IeApp = Nothing 
End Sub 

Это очень полезно для перечисления всех ссылок на сайте. Как я могу прокручивать эти URL-адреса и импортировать данные из каждого?

Например, первая ссылка в разделе «Имя или сектора» заключается в следующем: http://www.sharenet.co.za/v3/sharesfound.php?ssector=0533&exch=JSE&bookmark=Oil & Газ & схема = по умолчанию

Там на самом деле ничего импортировать оттуда. Следующее звено имеет некоторые данные: http://www.sharenet.co.za/v3/sharesfound.php?ssector=0537&exch=JSE&bookmark=Oil%20-%20Integrated&scheme=default

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

Name Full Name Code Sector 
SACOIL-N Sacoil Holdings Ltd NPL SCLN 0537 
ERIN Erin Energy Corporation ERN  0537 
BEE-SASOL  BEE - SASOL LIMITED SOLBE1 0537 
SACOIL  SACOIL HOLDINGS LD  SCL  0537 
OANDO  OANDO PLC  OAO  0537 
OANDORIGT  OANDO PLC RIGT  OAON 0537 
MONTAUK  Montauk Holdings Ltd  MNK  0537 

Как я могу импортировать эти данные из каждой ссылки?

Answer 1

Это, похоже, работает очень хорошо. Это может потребоваться немного тонкой настройки, но это должно быть довольно близко.

Sub ListLinks() 

'Set a reference to microsoft Internet Controls 
Dim IeApp As InternetExplorer 
Dim sURL As String 
Dim IeDoc As Object 
Dim i As Long 

Set IeApp = New InternetExplorer 

IeApp.Visible = True 
sURL = "http://www.sharenet.co.za/v3/q_sharelookup.php" 
IeApp.Navigate sURL 

Do 
Loop Until IeApp.ReadyState = READYSTATE_COMPLETE 
Set IeDoc = IeApp.Document 
    For i = 0 To IeDoc.Links.Length - 1 
     Cells(i + 1, 1).Value = IeDoc.Links(i).href 
    Next i 
Set IeApp = Nothing 
Call CopyFromURL 
End Sub 


Public Sub CopyFromURL() 
Dim IE As InternetExplorer, doc As HTMLDocument 
Dim thisClass As IHTMLElement2, thisLink As IHTMLElement 
Dim rng As Range, cell As Range 
Const READYSTATE_COMPLETE As Integer = 4 
Dim TR_col As Object, TR As Object 
Dim TD_col As Object, TD As Object 
Dim row As Long, col As Long 
row = 1 
Set rng = Range("A1:A5") 
For Each cell In rng 

    Set IE = CreateObject("InternetExplorer.Application") 
    IE.Navigate cell 

    Do While (IE.Busy Or IE.ReadyState <> READYSTATE_COMPLETE) 
     DoEvents 
    Loop 

    Set TR_col = IE.Document.getElementsByTagName("TR") 

    For Each TR In TR_col 
     Set TD_col = TR.getElementsByTagName("TD") 

col = 2 
     For Each TD In TD_col 
      Cells(row, col) = TD.innerText 
      col = col + 1 
     Next 
     col = 2 
     row = row + 1 
    Next 

Next cell 
IE.Quit 
End Sub