locked
Import Data from Balance Sheets Published on Yahoo Finance RRS feed

  • Question

  • Hello, I found this VBA Code here:

    Sub Test()
    Dim sTicker As String, sQT As String
    Dim rInsert As Range
    
        sTicker = "MSFT"
        Set rInsert = ActiveSheet.Range("B3")
        ActiveSheet.Range("A2") = sTicker
    
        sQT = QTBalanceSheet(rInsert, sTicker)
        ActiveSheet.Range("B2") = "Query name: " & sQT '
       ' will need to refresh manually or with code
        
    End Sub
    
    Function QTBalanceSheet(rInsert As Range, sTicker As String)
    Dim sCon As String
    Dim qt As QueryTable
    
        sCon = "URL;https://finance.yahoo.com/q/bs?s=<ticker>+Balance+Sheet&annual"
        sCon = Replace(sCon, "<ticker>", sTicker)
    
        Set qt = ActiveSheet.QueryTables.Add(Connection:=sCon, Destination:=rInsert)
        With qt
            .Name = sTicker & "BalanceSheet&Annual"
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .BackgroundQuery = True
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .WebSelectionType = xlSpecifiedTables
            .WebFormatting = xlWebFormattingNone
            .WebTables = "9"
            .WebPreFormattedTextToColumns = True
            .WebConsecutiveDelimitersAsOne = True
            .WebSingleBlockTextImport = False
            .WebDisableDateRecognition = False
            .WebDisableRedirections = False
            .Refresh BackgroundQuery:=False
            QTBalanceSheet = .Name
        End With
        
    End Function

    It seems, yahoo finance changed the URL.

    https://finance.yahoo.com/quote/AAPL/financials?p=AAPL

    Do you have any change how to fix this problem, that it works also with the new URL? Or is there any other solution?

    Many thanks for all your help.

    Best regards,

    Nico

    Tuesday, April 11, 2017 9:06 PM

All replies

  • Hi Nico,

    Thanks for visiting our forum.

    Then this is the forum to discuss questions and feedback for Microsoft Excel, since you issue is about VBA code, I'll move your question to the MSDN forum for Excel:

    https://social.msdn.microsoft.com/Forums/en-US/home?forum=exceldev

    The reason why we recommend posting appropriately is you will get the most qualified pool of respondents, and other partners who read the forums regularly can either share their knowledge or learn from your interaction with us. Thank you for your understanding.

    Best regards,
    Yuki Sun


    Please remember to mark the replies as answers if they helped.

    If you have feedback for TechNet Subscriber Support, contact tnmff@microsoft.com.

    Wednesday, April 12, 2017 6:06 AM
  • I think yahoo changed it's site recently. Just check your URL, and get that working first.

    http://finance.yahoo.com/quote/IBM/financials?p=IBM

    When you know that is right, engineer everything else around that.

    Here is a solution that works for me. This imports data for several tickers, listed in a sheet, in cells A2, down to the end of the array.

    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")
        ' http://finance.yahoo.com/quote/" & Symbol & "/financials?ltr=1
        xmlHttp.Open "GET", "http://finance.yahoo.com/quote/" & Symbol & "/financials?ltr=1", 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

    Here is a screen shot of my setup.


    MY BOOK

    Thursday, April 13, 2017 12:31 PM
  • Hi Rygu72,

    many thanks for your help and support regarding my question.

    Yes, you´re right. Yahoo changed the entire URL. Therefore my old code is not working anymore.

    Yor code is very helpfull. Many thanks for that. 

    Is there any chance to retrieve all quotes of the Financials 

    • Income Statement
    • Cash Flow
    • Balance Sheet

    Is there also a chance to retrieve this for annual and quarterly?

    I m absolutely not able to engineer everything else around that.

    I would be very very happy if you could help me with that.

    Thanks,

    Nico

    Monday, April 17, 2017 2:53 PM
  • Hello,

    Excel provides web query to retrieve data from a website table. It works for the old website because the data is stored in a table. But for new website, I have checked the website element, I think they are in the iframe. From Office Object Model, we could not retrieve the data.

    Regards,

    Celeste


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Tuesday, April 25, 2017 6:13 AM