股票從雅虎財務報表不再transferrinf脫穎而出

Question

1. 我有轉個股財務報表（損益表，資產負債表，現金流量）從雅虎金融到Excel中的VBA代碼，我已經使用了一段時間現在，但似乎雅虎已經改變了鏈接或東西。有人可以幫助我重新鏈接鏈接，以便編碼再次將拉動的信息從雅虎轉移到Excel嗎？下面是編碼

   子FinancialStatements（） 昏暗的股票作爲字符串 昏暗urlend作爲字符串

   Application.ScreenUpdating = False 
   
   
   ticker = Sheets("inputs").Cells(2, 1) 
   If Sheets("Inputs").Shapes("Check Box 14").ControlFormat.Value = 1 Then 
       urlend = "&annual" 
   Else: urlend = "" 
   
   End If 
   
   
   
   Sheets("Income Statement").Select 
   Cells.Clear 
   
   If Sheets("Inputs").Shapes("Check Box 11").ControlFormat.Value = 1 Then 
   
   ' 
       With ActiveSheet.QueryTables.Add(Connection:= _ 
        "URL;http://finance.yahoo.com/q/is?s=" & ticker & "" & urlend & "", Destination:=Range("$A$1") _ 
   ) 
   .Name = "is?s=MSFT&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 
       End With 
   
        End If 
   
   
       Sheets("Balance Sheet").Select 
   Cells.Clear 
   
   If Sheets("Inputs").Shapes("Check Box 12").ControlFormat.Value = 1 Then 
   
   ' 
       With ActiveSheet.QueryTables.Add(Connection:= _ 
        "URL;http://finance.yahoo.com/q/bs?s=" & ticker & "" & urlend & "", Destination:=Range("$A$1") _ 
   ) 
   .Name = "is?s=MSFT&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 
       End With 
        End If 
   
   Sheets("Cash Flows").Select 
   Cells.Clear 
   If Sheets("Inputs").Shapes("Check Box 13").ControlFormat.Value = 1 Then 
   
   ' 
       With ActiveSheet.QueryTables.Add(Connection:= _ 
   "URL;http://finance.yahoo.com/q/cf?s=" & ticker & "" & urlend & "", Destination:=Range("$A$1") _ 
   ) 
   .Name = "is?s=MSFT&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 
       End With 
   End If 
   
   
   Application.ScreenUpdating = True 
   
   End Sub 
   

Answer 1

我認爲雅虎改變了它的網站最近。只需檢查您的網址，然後先開始工作即可。

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

當你知道這是正確的，工程周圍的一切是其他。

這是一個適合我的解決方案。這將單元格A2中的多個代號（列表在工作表中）的數據導入數組的末尾。

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 

這是我的設置的屏幕快照。