Question

我正在尝试创建一种通过VBA从Yahoo Finance（例如https://finance.yahoo.com/quote/FB/financials?p=FB）提取财务报表（基本表）的快速方法。我是一个完全菜鸟，所以我使用了记录宏工具，并从Web上获取数据，并尝试（使用我不存在的VBA知识）使它适应于使用变量（股票代号）来更改公司。

使用从Web函数获取数据时，表格可以完美导入，但不适用于VBA代码。我收到有关ListObject.DisplayName或Refresh BackgroundQuery的1004错误

Sub Macro5()
Dim Ticker As String
Ticker = InputBox("Ticker")
ActiveWorkbook.Queries.Add Name:="Table" & Ticker, Formula:= _
    "let" & Chr(13) & "" & Chr(10) & "    Source = Web.Page(Web.Contents(""https://finance.yahoo.com/quote/& Ticker &/financials?p=&Ticker &""))," & Chr(13) & "" & Chr(10) & "    Data2 = Source{2}[Data]," & Chr(13) & "" & Chr(10) & "    #""Type modifié"" = Table.TransformColumnTypes(Data2,{{""Column1"", type text}, {""Column2"", type text}, {""Column3"", type text}, {""Column4"", type text}, {""Column5"", type text}})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & "    #""Type modifié"""
ActiveWorkbook.Worksheets.Add
With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
    "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Extended Properties=""""" _
    , Destination:=Range("$A$1")).QueryTable
    .CommandType = xlCmdSql
    .CommandText = Array("SELECT * FROM [Table & Ticker")
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .BackgroundQuery = True
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .PreserveColumnInfo = True
    .ListObject.DisplayName = "Table" & Ticker
    .Refresh BackgroundQuery:=False
End With
End Sub

这个想法是为“ Ticker”（我的例子中为FB）输出损益表。我在Windows上使用Excel 365

非常感谢

Answer 1

一种简单的方法是获取页面上的所有表格元素，并使用剪贴板将其复制到工作表中，从而进行循环。您可以根据报价值调整以写入不同的工作表。在代码行上方使用一个循环来检索数据，但要确保在循环前创建ie对象，然后在循环内包含navigation2以便访问每个新的代码行页面。

Public Sub GetTables()
    Dim clipboard As Object, ws As Worksheet, j As Long, tables As Object
    Dim ie As Object, ticker As String
    ticker = "FB"
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    ws.Cells.UnMerge
    ws.Cells.ClearContents
    Set clipboard = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")

    Application.ScreenUpdating = False
    Set ie = CreateObject("InternetExplorer.Application")
    With ie
        .Visible = True
        .Navigate2 "https://finance.yahoo.com/quote/FB/financials?p=" & ticker

        While .Busy Or .readyState < 4: DoEvents: Wend

        Set tables = .document.querySelectorAll("table")

        For j = 0 To tables.Length - 1
            clipboard.SetText tables.item(j).outerHTML
            clipboard.PutInClipboard
            ws.Cells(LastRow(ws) + 2, 1).PasteSpecial
        Next
        .Quit
    End With

    Application.ScreenUpdating = True
End Sub

'https://www.rondebruin.nl/win/s9/win005.htm

Public Function LastRow(ByVal sh As Worksheet) As Long
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function

第二种方法对您来说是一个知识上的飞跃，但将来可能对其他读者有用。您可以从脚本标签中提取页面上的所有信息。通过对该脚本元素的innerHTML进行一些字符串拆分，您可以获得json解析器可以处理的字符串。然后，您可以解析json以获取所需的任何信息。我仅在下面提供一个大纲。

Option Explicit
'VBE > Tools > References:
' Microsoft Internet Controls
' Microsoft Scripting Runtime
'Download and add in jsonconverter.bas from https://github.com/VBA-tools/VBA-JSON/blob/master/JsonConverter.bas
Public Sub GetYahooData()
    Dim IE As New InternetExplorer, ticker As String
    ticker = "FB"
    With IE
        .Visible = True
        .Navigate2 "https://finance.yahoo.com/quote/FB/financials?p=" & ticker

        While .Busy Or .readyState < 4: DoEvents: Wend

        Dim script As Object, scripts As Object, i As Long, extract As String, json As Object
        Set scripts = .document.querySelectorAll("script")

        For i = 0 To scripts.Length - 1
            If InStr(1, scripts.item(i).innerHTML, "/* -- Data -- */") Then
                Set script = scripts.item(i)
                Exit For
            End If
        Next
        If Not script Is Nothing Then
            extract = Split(Split(script.innerHTML, "root.App.main = ")(1), "(this));")(0)
            extract = Left$(extract, InStrRev(extract, ";") - 1)
            Set json = JsonConverter.ParseJson(extract)("context")("dispatcher")("stores")("QuoteSummaryStore")("cashflowStatementHistory")
        End If
        If Not json Is Nothing Then
            'parse json for data of interest
        End If
        Stop ' <== Delete me later
        .Quit
    End With
End Sub

json中确实有太多信息无法通过，但这是左侧网页的快照摘录，而右侧是与之相关的json：

Answer 2

我尝试对您采用的代码进行锻炼。当我们从网上通过Excel数据标签检索网址时，页面上您感兴趣的表格为Table 2。我们必须解决两个问题。

表引用正确。当我们运行该程序时，查询表名位于Excel内存中，即使删除工作表也不会删除它。因此，我必须在表中的3个位置增加表索引[Table 2 (2)]，然后下一次[Table 2 (3)]。如果每次程序正常运行时我们递增表索引。找出表ListTables()子例程的索引号是有帮助的。我找不到适合的方法，使Excel不记得已删除工作表的表索引。

第二个必要点是关闭连接。我已经为它添加了合适的代码。最终代码如下所示。

 Sub Macro7()
 '
 ' Macro1 Macro
 '

 '
Dim Cn As Variant
Dim Ticker As String

Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Ticker = InputBox("Ticker")

ActiveWorkbook.Queries.Add Name:="Table 2 (18)", Formula:= _
    "let" & Chr(13) & "" & Chr(10) & "    Source = Web.Page(Web.Contents(""https://finance.yahoo.com/quote/" & Ticker & "/financials?p=" & Ticker & """))," & Chr(13) & "" & Chr(10) & "    Data2 = Source{2}[Data]," & Chr(13) & "" & Chr(10) & "    #""Changed Type"" = Table.TransformColumnTypes(Data2,{{""Column1"", type text}, {""Column2"", type text}, {""Column3"", type text}, {""Column4"", type text}, {""Column5"", type text}})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & "    #""Changed Type"""
ActiveWorkbook.Worksheets.Add
With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
    "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=""Table 2 (2)"";Extended Properties=""""" _
    , Destination:=Range("$A$1")).QueryTable
    .CommandType = xlCmdSql
    .CommandText = Array("SELECT * FROM [Table 2 (18)]")
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .BackgroundQuery = True
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .PreserveColumnInfo = True
    .ListObject.DisplayName = "Table_2__18"
    .Refresh BackgroundQuery:=False
End With
'Range("A16").Select
For Each Cn In ThisWorkbook.Connections
    Cn.Delete
 Next Cn
For Each Cn In ActiveSheet.QueryTables
    Cn.Delete
Next Cn

Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True


End Sub

列出表索引的代码例程为：

Sub ListTables()
    Dim xTable As ListObject
    Dim xSheet As Worksheet
    Dim I As Long
    I = -1
    Sheets.Add.Name = "Table Name"
    For Each xSheet In Worksheets
    For Each xTable In xSheet.ListObjects
    I = I + 1
    Sheets("Table Name").Range("A1").Offset(I).Value = xTable.Name
    Sheets("Table Name").Range("B1").Offset(I).Value = xSheet.Name
    Next xTable
    Next
End Sub

使用ActiveWorkbook.Queries.Add拉表时出现错误1004

2 个答案: