股票从雅虎财务报表不再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 

这是我的设置的屏幕快照。