How to download data from web using TR and TD tag

Question

Until recently, I was using the code below, which worked fine for a while. Now, all of a sudden it doesn't work.

Sub Dow_HistoricalData()

    Dim xmlHttp As Object
    Dim TR_col As Object, TR As Object
    Dim TD_col As Object, TD As Object
    Dim row As Long, col As Long

    ThisSheet = ActiveSheet.Name
    Range("A2").Select
    Do Until ActiveCell.Value = ""
    Symbol = ActiveCell.Value
    Sheets(ThisSheet).Select
    Sheets.Add

    Set xmlHttp = CreateObject("MSXML2.XMLHTTP.6.0")
    myURL = "http://finance.yahoo.com/quote/" & Symbol & "/financials?ltr=1"
    xmlHttp.Open "GET", myURL, False
    xmlHttp.setRequestHeader "Content-Type", "text/xml"
    xmlHttp.send

    Dim html As Object
    Set html = CreateObject("htmlfile")
    html.body.innerHTML = xmlHttp.responseText

    Dim tbl As Object
    Set tbl = html.getElementById("Lh(1.7) W(100%) M(0)")
    '

    row = 1
    col = 1

    Set TR_col = html.getElementsByTagName("TR")
    For Each TR In TR_col
        Set TD_col = TR.getElementsByTagName("TD")
        For Each TD In TD_col
            Cells(row, col) = TD.innerText
            col = col + 1
        Next
        col = 1
        row = row + 1
    Next

Sheets(ActiveSheet.Name).Name = Symbol
Sheets(ThisSheet).Select
ActiveCell.Offset(1, 0).Select

Loop

End Sub

I'm getting an error message in this line: xmlHttp.send

Here's the error message. 'Access is denied.' I did some research on this, and I think it has to do with security, but I don't know what has changed recently, either on my machine or on the Yahoo site.

Here is an image of my setup.

Answer 1

Seems to work if you fake the browser:

With CreateObject("WinHttp.WinHttpRequest.5.1") '
    .Open "GET", "http://finance.yahoo.com/quote/IBM", False
    .SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows; U; Windows NT 6.0; en-US; rv:1.9b5) Gecko/2008032620 Firefox/3.0b5"
    .Send
    MsgBox .ResponseText
End With

Answer 2

I believe URL has moved from http to https so the error. Also, I Changed to CreateObject("MSXML2.ServerXMLHTTP")

Sub Dow_HistoricalData()

    Dim xmlHttp As Object, html As Object
    Dim tbl As Object
    Dim TR_col As Object, TR As Object
    Dim TD_col As Object, TD As Object
    Dim row As Long, col As Long, i As Long
    Dim sht As Worksheet, newSht As Worksheet


    Set sht = ActiveSheet


    i = 2
    Do Until sht.Cells(i, 1) = ""

        Set newSht = Sheets.Add
        Symbol = sht.Cells(i, 1)
        newSht.Name = Symbol

        Set xmlHttp = CreateObject("MSXML2.ServerXMLHTTP")
        myURL = "https://finance.yahoo.com/quote/" & Symbol & "/financials?ltr=1"
        xmlHttp.Open "GET", myURL, False
        xmlHttp.setRequestHeader "Content-Type", "text/xml"
        xmlHttp.send


        Set html = CreateObject("htmlfile")
        html.body.innerHTML = xmlHttp.responseText


        Set tbl = html.getElementById("Lh(1.7) W(100%) M(0)")
'

        row = 1
        col = 1

        Set TR_col = html.getElementsByTagName("TR")
        For Each TR In TR_col
            Set TD_col = TR.getElementsByTagName("TD")
            For Each TD In TD_col
                newSht.Cells(row, col) = TD.innerText
                col = col + 1
            Next
            col = 1
            row = row + 1
        Next

        i = i + 1
    Loop


     Set TR_col = Nothing
     Set TR = Nothing
     Set TD = Nothing
     Set html = Nothing
     Set xmlHttp = Nothing


End Sub