Navigate and getting data from website

arunsjain

Board Regular
Joined
Apr 29, 2016
Messages
75
Hi All,


I am looking for VBA code where following steps areperformed:



Open website https://www.abs.gov.au/Price-Indexes-and-Inflation


Click on link “Consumer Price Index” on that page.


Click on “Download” tab on that page.


Open .Xls file from that page (do not save that file).


Copy Data in tab “Data” from open file and paste in currentfile in sheet 1 and close that open file without saving.


Could anyone please help regarding this? Highly appreciate your help.

Cheers!!!
 
Last edited:

Worf

Well-known Member
Joined
Oct 30, 2011
Messages
3,760
Hi

This is the first part; I will be back during the week to complete it.

Code:
Sub Scrape()
Dim Browser As InternetExplorer, Document As HTMLDocument, Elements
Dim Element As IHTMLElement, doc, i%, r As Range
Set r = [a2]
Set Browser = New InternetExplorer
Browser.Visible = True
Browser.navigate "https://www.abs.gov.au/Price-Indexes-and-Inflation"
Do While Browser.Busy And Not Browser.readyState = READYSTATE_COMPLETE
    DoEvents
Loop
Set doc = Browser.Document
Set Elements = doc.getElementsByTagName("a")
For i = 0 To Elements.Length - 1
    If Elements(i).textContent = "Consumer Price Index" Then
        MsgBox "found"
        Elements(i).Click
    End If
Next
MsgBox Elements.Length, , "elements"
End Sub
 

Worf

Well-known Member
Joined
Oct 30, 2011
Messages
3,760
The page has 12 workbooks, which one do you want?

Code:
Sub Scrape()
Dim Browser As InternetExplorer, Document As HTMLDocument, Elements
Dim Element As IHTMLElement, doc, i%
Set Browser = New InternetExplorer
Browser.Visible = True
Browser.navigate "https://www.abs.gov.au/Price-Indexes-and-Inflation"
Do While Browser.Busy And Not Browser.readyState = READYSTATE_COMPLETE
    DoEvents
Loop
Set doc = Browser.Document
DoEvents
Set Elements = doc.getElementsByTagName("a")
For i = 0 To Elements.Length - 1
    If Elements(i).textContent = "Consumer Price Index" Then
        MsgBox "found consumer"
        Elements(i).Click
    End If
Next
MsgBox Elements.Length, , "a elements"
Set doc = Browser.Document
Set Elements = doc.getElementsByTagName("span")
MsgBox Elements.Length, , "span"
For i = 0 To Elements.Length - 1
    If Elements(i).textContent = "Downloads" Then
        MsgBox "found download"
        Elements(i).Click
    End If
Next
Set doc = Browser.Document
Set Elements = doc.getElementsByTagName("img")
MsgBox Elements.Length, , "Image elements"
End Sub
 

arunsjain

Board Regular
Joined
Apr 29, 2016
Messages
75
Thank you so much Worf.

I need first file "TABLES1 and 2. CPI: All Groups, Index Numbers and Percentage Changes".


 

Worf

Well-known Member
Joined
Oct 30, 2011
Messages
3,760
IE automation is not completely reliable, but the code below brings up the dialog window to download the file.
Now I will decide whether to use the send keys method or something more elegant.

Code:
Sub Scrape()
Dim Browser As InternetExplorer, Document As HTMLDocument, Elements
Dim Element As IHTMLElement, doc, i%, r As Range, elem2, iel%
Set Browser = New InternetExplorer
Browser.Visible = True
Browser.navigate "https://www.abs.gov.au/Price-Indexes-and-Inflation"
Do While Browser.Busy And Not Browser.readyState = READYSTATE_COMPLETE
    DoEvents
Loop
Set doc = Browser.Document
DoEvents
Set Elements = doc.getElementsByTagName("a")
For i = 0 To Elements.Length - 1
    If Elements(i).textContent = "Consumer Price Index" Then
        MsgBox "found consumer"
        Elements(i).Click
    End If
Next
MsgBox Elements.Length, , "a elements"
Set doc = Browser.Document
Set Elements = doc.getElementsByTagName("span")
MsgBox Elements.Length, , "span"
For i = 0 To Elements.Length - 1
    If Elements(i).textContent = "Downloads" Then
        MsgBox "found download"
        Elements(i).Click
    End If
Next
Set doc = Browser.Document
Set elem2 = doc.getElementsByTagName("img")
iel = elem2.Length
MsgBox iel, , "Image elements"
For i = 0 To iel - 1
    Set elem2 = doc.getElementsByTagName("img")
    If elem2(i).Title Like "*136*" Then elem2(i).Click
Next
Set doc = Nothing
End Sub
 

Worf

Well-known Member
Joined
Oct 30, 2011
Messages
3,760
John

I did not test your method because the pop up at that site does not seem to be the download notification bar.
The code below uses send keys for the time being. The second macro copies the required data, which is the last step in this project.

Code:
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]Sub Scrape2()
Dim Browser As InternetExplorer, Document As HTMLDocument, Elements
Dim Element As IHTMLElement, doc, i%, r As Range, elem2, iel%, macrosec%
macrosec = Application.AutomationSecurity
Application.AutomationSecurity = msoAutomationSecurityLow   ' avoid protected view
Set Browser = New InternetExplorer
Browser.Visible = True
Browser.navigate "https://www.abs.gov.au/Price-Indexes-and-Inflation"
Do While Browser.Busy And Not Browser.readyState = READYSTATE_COMPLETE
    DoEvents
Loop
Set doc = Browser.Document
DoEvents
Set Elements = doc.getElementsByTagName("a")
For i = 0 To Elements.Length - 1
    If Elements(i).textContent = "Consumer Price Index" Then
        MsgBox "found consumer"
        Elements(i).Click
    End If
Next
MsgBox Elements.Length, , "a elements"
Set doc = Browser.Document
Set Elements = doc.getElementsByTagName("span")
For i = 0 To Elements.Length - 1
    If Elements(i).textContent = "Downloads" Then
        MsgBox "found download"
        Elements(i).Click
    End If
Next
Set doc = Browser.Document
Set elem2 = doc.getElementsByTagName("img")
iel = elem2.Length
MsgBox iel, , "Image elements"
For i = 0 To iel - 1
    Set elem2 = doc.getElementsByTagName("img")
    If elem2(i).Title Like "*136*" Then elem2(i).Click
Next
Application.Wait (Now + TimeValue("0:00:04"))
DoEvents
SendKeys "%a"           ' this is Alt + A
Set doc = Nothing
Application.AutomationSecurity = macrosec
End Sub[/FONT]
Code:
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]Sub TwoWorkbooks()
Dim orig As Workbook, dataw As Workbook
If Application.Workbooks.Count > 2 Then
    MsgBox "Too many workbooks opened..."
    Exit Sub
End If
Select Case Workbooks(1).Name Like "*Automation*"
    Case True
        Set orig = Workbooks(1)
        Set dataw = Workbooks(2)
    Case False
        Set orig = Workbooks(2)
        Set dataw = Workbooks(1)
End Select
MsgBox orig.Name & vbLf & dataw.Name
dataw.Sheets("data1").UsedRange.Copy orig.Sheets("sheet1").[a1]
dataw.Close 0
End Sub[/FONT]
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
5,960
John

I did not test your method because the pop up at that site does not seem to be the download notification bar.
You are correct: it doesn't display the normal Download Notification Bar at the bottom of the IE window, but a "What do you want to do with xxxxx.xxx?" dialogue:



I have seen this before on another website and I've found a reason why it happens. I have updated my UIAutomation code to also handle this dialogue and will post details of my diagnosis in https://www.mrexcel.com/forum/general-excel-discussion-other-questions/1086615-using-uiautomationclient-automate-save-file-download-ie11.html.
 

Kyle123

Well-known Member
Joined
Jan 24, 2012
Messages
2,667
Another way:
Code:
Option Explicit
Public Sub GetCPIData()

    Dim savePath    As String
    Dim wb          As Workbook
    
    savePath = Envrion("Temp") & "\test.xls"
    Set wb = SaveCPIWorkbook(savePath)
    
    wb.Sheets("Data1").UsedRange.Copy ThisWorkbook.Sheets("Sheet1").Range("a1")
    
    wb.Close False
    
    Kill savePath

End Sub



Public Function SaveCPIWorkbook(savePath As String) As Workbook
    
    Dim ifileNum As Long
    Dim fileBytes() As Byte
    
    ifileNum = FreeFile
    
    With CreateObject("winhttp.winhttprequest.5.1")
        .Open "GET", getDownloadUrl(), False
        .send
        fileBytes = .responseBody
        Kill savePath
        Open savePath For Binary As [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=ifileNum]#ifileNum[/URL] 
           Put [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=ifileNum]#ifileNum[/URL] , , fileBytes
        Close [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=ifileNum]#ifileNum[/URL] 
    End With
    
    Set savespiworkbook = Workbooks.Open(savePath)
    
End Function

Private Function getDownloadUrl()

    Const BaseUrl   As String = "https://www.abs.gov.au/"
    Dim doc         As HTMLDocument
    
    Set doc = New HTMLDocument
    
    doc.body.innerHTML = getSyncRequestResponse(BaseUrl & "Price-Indexes-and-Inflation")
    doc.body.innerHTML = getSyncRequestResponse(BaseUrl & getAnchorByContent(doc, "#element2list a", "Consumer Price Index").pathname)
    doc.body.innerHTML = getSyncRequestResponse(BaseUrl & getAnchorByContent(doc, "#tabsJ a", "Downloads").pathname)
    
    getDownloadUrl = BaseUrl & getAnchorByContent(doc, ".listentry a", "").pathname

End Function

Private Function getAnchorByContent(dom As HTMLDocument, selector As String, content As String) As HTMLAnchorElement
    
    Dim a           As Object
    Dim nodeList    As IHTMLDOMChildrenCollection
    Dim x           As Long
    
    Set nodeList = dom.querySelectorAll(selector)
    
    For x = 0 To nodeList.Length
        Set a = nodeList(x)
        If a.innerText = content Then
            Set getAnchorByContent = a
            Exit For
        End If
    Next x
    
End Function

Private Function getSyncRequestResponse(url As String) As String
    Static request As Object
    If request Is Nothing Then Set request = CreateObject("MSXML2.XMLHTTP")
    
    With request
        .Open "GET", url, False
        .send
        getSyncRequestResponse = .responseText
    End With
    
End Function
 

arunsjain

Board Regular
Joined
Apr 29, 2016
Messages
75
Thank you so much for your help Worf and Kyle123. Highly appreciated.

Cheers!!
 
Last edited:

Forum statistics

Threads
1,078,515
Messages
5,340,861
Members
399,396
Latest member
PBE

Some videos you may like

This Week's Hot Topics

  • Problem with Radio Button's format control
    I am creating an employee evaluation template (a sample is below) Column A is the category Column B, C D, E and F will be ratings (unacceptable...
  • Last Display on userform to a Listbox
    [CODE=vba] lstdisplay.ColumnCount = 15 lstdisplay.RowSource = "A1:O600000" [/CODE] So when i do this it Displays everything on the sheet i am...
  • Rename and move files to a new location
    Dear all, I have an excel file with the following information. The actual file name is at column A but i want to rename it using the following...
  • Help with True/False Formula
    Hello! Am stumped how to fix this formula, in which my result returns 'True', but it should return False. =IF(AG2=True...
  • Clear extra characters from a provided range of cells
    Dear All, I have following code which gives me desired output to remove extra characters from a provided range. But it takes too much time when...
  • Help with Current and highest streaks
    Hi there, I've just joined the forum and this is my first post. I've already spent quite a bit of time searching the net and this forum for a...
Top