Question

我有一个VBA代码将股票财务报表（损益表，资产负债表，现金流）从雅虎财务转移到excel，我已经使用了一段时间了，但似乎雅虎已经改变了链接或一些东西。有人可以帮我重新链接链接，以便编码将拉出的信息从雅虎再次转移到excel吗？以下是编码

子财务报表（） Dim ticker As String Dim urlend As String

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

以下是我的设置的屏幕截图。

来自雅虎的股票财务报表不再转移到excel

1 个答案: