Copy html table with dropdown menu into excel vba

[Reis]

Good morning to all. Let's see if someone can help me out with this, cause it is making me crazy. I´ve been looking all over to try to make this work on Excel and still can´t make it happen. I have a webpage, with a dropdown menu for selection, and then it presents a table that i want to copy to excel using VBA.

Webpage: Cotações BPI

In here, i find 4 options:

• Câmbios
• Fundos de Investimento
• PPR
• Seguros de Capitalização

I Want to select the second one "Fundos de Investimento", wait for IE to load the page and then fill the cells on an excel page.
After, need to select third option "PPR", wait for IE to load the page and then fill the cells on another excel page.

Managed to get something, nut now the problem is that the page doesn't update with selection on drop-down menu.

My code:

Sub demo()
Dim IE
Dim ro As Integer
Dim Table As Object
Dim trows As Object
Dim r As Object
Dim tcells As Object
Dim c As Object
Dim objIE As Object
Dim Title As Object


Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True
IE.Navigate "Cotações BPI"

Do While IE.Busy
Application.Wait DateAdd("s", 1, Now)
Loop

Set Title = IE.Document.getElementById("wt2_LT_SitePublico_wt151_block_wtContent_wtContent_CW_SP_Fragments_wt3_block_LT_SitePublico_wt10_block_wtLeftContent_LT_SitePublico_Patterns_wt165_block_wtForm_LT_SitePublico_Patterns_wt51_block_wtRow_LT_SitePublico_Patterns_wt228_block_wtInput_wtSelAcoes")
Title.selectedIndex = 1

Application.Wait DateAdd("s", 1, Now)

Set Table = IE.Document.getElementsByTagName("table")
Set trows = Table(0).getElementsByTagName("tr")

ro = 1
For Each r In trows
Set tcells = r.getElementsByTagName("td")
For Each c In tcells

Debug.Print (c.innerText)

ro = ro + 1
Next
Next

End Sub

 

[John_w]

Try this macro. The "Fundos de Investimento" data is extracted into the first sheet in the workbook and the "PPR" data into the second sheet.

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If


Public Sub IE_Extract_Data()

    Dim IE As Object 'InternetExplorer
    Dim HTMLdoc As Object 'HTMLDocument
    Dim selectElement As Object 'HTMLSelectElement
    Dim table As Object 'HTMLTable
    Dim tRow As Object 'HTMLTableRow
    Dim tCell As Object 'HTMLTableCell
    Dim optionIndex As Long
    Dim i As Long, r As Long
    Dim URL As String
    Dim destCell As Range
    
    With ThisWorkbook.Worksheets(1)
        .Cells.Clear
        Set destCell = .Range("A1")
    End With
    
    Set IE = CreateObject("InternetExplorer.Application")
    With IE
        .navigate "https://www.bancobpi.pt/cotacoes"
        .Visible = True
        Do While .Busy Or .readyState <> 4: DoEvents: Loop
        Set HTMLdoc = .document
    End With
        
    Set selectElement = HTMLdoc.getElementsByTagName("select")(0)
    
    optionIndex = FindSelectOption(selectElement, "Fundos de Investimento")
    selectElement.selectedIndex = optionIndex
    selectElement.FireEvent "onchange"
    Do
        DoEvents
        Sleep 100
    Loop Until HTMLdoc.querySelector("div.h2.OSInline").innerText = "Fundos de Investimento"
   
    Set table = HTMLdoc.getElementsByTagName("table")(0)
    For r = 0 To table.Rows.Length - 1
        Set tRow = table.Rows(r)
        For Each tCell In tRow.Cells
            destCell.Offset(tRow.RowIndex, tCell.cellIndex).Value = tCell.innerText
        Next
    Next
    
    destCell.Worksheet.Columns.AutoFit
    
    With ThisWorkbook.Worksheets(2)
        .Cells.Clear
        Set destCell = .Range("A1")
    End With
     
    optionIndex = FindSelectOption(selectElement, "PPR")
    selectElement.selectedIndex = optionIndex
    selectElement.FireEvent "onchange"
    Do
        DoEvents
        Sleep 100
    Loop Until HTMLdoc.querySelector("div.h2.OSInline").innerText = "PPR"
   
    Set table = HTMLdoc.getElementsByTagName("table")(0)
    For r = 0 To table.Rows.Length - 1
        Set tRow = table.Rows(r)
        For Each tCell In tRow.Cells
            destCell.Offset(tRow.RowIndex, tCell.cellIndex).Value = tCell.innerText
        Next
    Next
    
    destCell.Worksheet.Columns.AutoFit
    
    MsgBox "Done"
    
End Sub


Private Function FindSelectOption(selectElem As Object, optionText As String) As Long

    Dim i As Long
    For i = 0 To selectElem.Options.Length - 1
        If selectElem.Options(i).Text = optionText Then FindSelectOption = i
    Next

End Function

 

[Reis]

Good morning.
It gives me this error.
And apart from that, the column "Euros", doesn't put the comma there, so 7,76287€ returns 776287€.
It doesn't go past the first table, "Fundos de Investimento".

Thank you for your help.

 

[Reis]

I can't edit the last post. Managed to figure out what was happening it that error, i fixed it.
So the only thing remaining is the comma on the value, to set it 7 euros and not 700000 euros.

 

[John_w]

To fix the Euros issue, replace the two instances of tCell.innerText with Replace(tCell.innerText, ",", "."). Fortunately, no other column values contain a comma, otherwise a bit more code would be needed.

 

[Reis]

It worked flawless and like i wanted it to. Thank you so much for the help.