VBA 宏提供 Excel 2007 中的 Yahoo 股票报价下载

Dracula

4.63/5 (13投票s)

2014年3月7日

CPOL

6分钟阅读

131234

2979

VBA 宏提供 Excel 2007 中的 Yahoo 股票报价下载

下载包含源代码的 VBA 导出文件 - 4.2 KB

引言

提供一套 VBA 宏和函数，通过 Yahoo Query Language 从 Yahoo Finance 下载和解析实时股票报价。

背景

早在 Office 97 发布时，微软就增加了一个很酷的新功能：Web Queries（网页查询）。以前，如果您想要实时数据，例如股票报价，您必须编写自己的“屏幕抓取器”，而现在您可以让 Office 来完成繁重的工作。当网页设计/布局发生变化时，它偶尔会出现一些小故障，但通常很容易修复。然而，随着时间的推移，越来越多的网站使得使用 Web Queries 变得越来越困难，至少对于我想为多只股票获取的数据而言是如此：开盘价、最高价、最低价、当前/收盘价、成交量、上次交易时间。

有一段时间，谷歌的金融 API 是一个受青睐的替代方案，但谷歌最近将其关闭，转而使用内置的 Google Docs 功能。

在过去几个月里，我用来获取多只股票报价的最后一个网站进行了一些更改，导致我的电子表格及其网页查询无法正常工作。搜索其他网站发现了前面提到的、已弃用的 Google Finance API。我找到了几篇关于 Yahoo Finance 的参考资料，包括历史报价数据和通过 CSV 文件下载（包括此插件），但没有找到可以直接下载多只股票数据（且无需中间文件）的方法。

我发现了一些通过 YQL（Yahoo Query Language）进行调用的代码，可以直接下载数据，例如这篇文章，这给了我一些想法。还有其他文章，但我没有记录所有参考（抱歉）。经过一些尝试和错误，我编写了这套 VBA 宏，我现在正在 Excel 2007 (32 位) 中使用它们。

了解 YQL 功能的一个好方法是使用控制台进行尝试；这是一个链接，当您在目标页面上按“测试”按钮时，它会显示请求雅虎、苹果、谷歌和微软的报价时返回的 XML。

我开发的 VBA 代码旨在用于电子表格，其中为每个股票代码串行调用，从而返回多个报价，并能访问比我在 Excel 的 Web Queries 可以访问的网站上找到的任何数据都多的数据。再次强调：我只在 Excel 2007 (32 位) 上测试过这些宏。进一步披露：所有工作也在 Windows 7 x64 上完成。您的使用情况可能有所不同。

重要提示：在使用 Excel 中的 VBA 代码之前，请确保您已包含 Microsoft XML v6（在 Microsoft Visual Basic 应用程序中，点击“工具”菜单，然后点击“引用”）。

Using the Code

此 VBA 代码的核心是 `GetQuoteXmlFromWeb` 函数。

 Function GetQuoteXmlFromWeb(stockSymbol As String) As MSXML2.IXMLDOMNode
    ' This is an Excel VBA function which returns XML data on a stock from
    ' Yahoo Finance's XML stream.
    ' GO TO TOOLS/REFERENCES and include Microsoft XML (tested w/ v6)
    
    ' Returns the XML Node List (or Nothing on error/failure)
    
    Dim QuoteXMLstream As MSXML2.DOMDocument
    Dim QuoteXMLHttp As MSXML2.XMLHTTP60
    
    Dim oChild As MSXML2.IXMLDOMNode
    
    Dim fSuccess As Boolean
    Dim URL As String
    
    On Error GoTo HandleErr
    
    ' create the URL that requests the XML stream from Yahoo Finance
    URL = "http://query.yahooapis.com/v1/public/yql?_
          q=SELECT%20*%20FROM%20yahoo.finance.quotes%20WHERE%20symbol%3D'" & Trim(stockSymbol) & "'"
    URL = URL & "&diagnostics=false&env=store%3A%2F%2Fdatatables.org%2Falltableswithkeys"
    
    ' pull in the XML stream
    Set QuoteXMLHttp = New MSXML2.XMLHTTP60
    With QuoteXMLHttp
        Call .Open("GET", URL, False)
        Call .send
    End With
    fSuccess = QuoteXMLHttp.Status
    
    If Not fSuccess Then                          ' quit on failure
      MsgBox "error loading Yahoo Finance XML stream"
      Exit Function
    End If
    
    ' Turn it into an XML document
    Set QuoteXMLstream = New MSXML2.DOMDocument
    fSuccsss = QuoteXMLstream.LoadXML(QuoteXMLHttp.responseText)
   
    If Not fSuccess Then                          ' quit on failure
      MsgBox "error parsing Yahoo Finance XML stream"
      Exit Function
    End If
    
    ' Structure is: query.results.quote (3 children in) to get to our quote params
    Set oChild = FindChildNodeName(QuoteXMLstream.ChildNodes, "query")
    If oChild Is Nothing Then
      MsgBox "error loading Yahoo Finance XML stream: cannot find 'query'"
      Exit Function
    End If
    
    Set oChild = FindChildNodeName(oChild.ChildNodes, "results")
    If oChild Is Nothing Then
      MsgBox "error loading Yahoo Finance XML stream: cannot find 'results'"
      Exit Function
    End If
    ' If this works, we will have the XML quote data node -- our target
    Set oChild = FindChildNodeName(oChild.ChildNodes, "quote")
    
    Set GetQuoteXmlFromWeb = oChild     ' Either the node or NOTHING
        
' error handlers
ExitHere:
            Exit Function
HandleErr:
            MsgBox "GetQuoteXmlFromWeb Error " & Err.Number & ": " & Err.Description
            Resume ExitHere
End Function

该函数接受一个参数：您希望检索其报价数据的股票代码。请注意使用 `FindChildNodeName` 函数来解析结果。

  ' Given an XML Dom Nodelist, find one of the child nodes whose name matches childName;
' return that node, else Nothing if not found.
'
Function FindChildNodeName(xmlChildren As MSXML2.IXMLDOMNodeList, childName As String) _
    As MSXML2.IXMLDOMNode
    Dim oChild As MSXML2.IXMLDOMNode
    Dim childResult As MSXML2.IXMLDOMNode
    
    Set childResult = Nothing
    
    For i = 1 To xmlChildren.Length
        Set oChild = xmlChildren.Item(i - 1)    ' 0-based index
        If oChild.nodeName = childName Then
            Set childResult = oChild
            Exit For
        End If
    Next
    
    ' childResult is either Nothing or the value we found
    Set FindChildNodeName = childResult
End Function

在 Yahoo 返回的初始结果 `QuoteXMLstream.ChildNodes` 中搜索的节点名称集，是基于 Yahoo 返回的观察到的 XML。

查找 `child` 节点，然后在其中查找
查找 `results` 节点，然后在其中查找
查找 `query` 节点；这是我们想要的数据所在的位置。

如果找不到所需的节点，则返回 `null`。成功时，所需股票的 XML 数据将作为 `MSXML2.IXMLDOMNode` 对象返回。现在，我们可以通过调用 `GetQuoteFromXml` 函数来提取其中的任何报价数据。

Function GetQuoteFromXml(stockXml As MSXML2.IXMLDOMNode, Optional QuoteParameter As String = _
     "LastTradePriceOnly", Optional statusText As String = "") As String

    ' This is an Excel VBA function which returns data about a stock
    ' from a Yahoo Finance XML stream
    ' GO TO TOOLS/REFERENCES and include Microsoft XML (tested w/ v6)
    
    ' For numeric values, call with Value() surrounding the result
    
    ' "stockXml" is the XML data returned by GetQuoteXmlFromWeb
    ' "statusText" is "" for no status bar updates, else the text to prepend to QuoteParameter 
    ' which we write to the status bar.
    ' it is up to the caller to enable status bar updates (i.e. set Application.DisplayStatusBar = True)
    ' "QuoteParameter" is one of the following node names, it defaults to "LastTradePriceOnly":
    '
'<?xml version="1.0" encoding="UTF-8"?>
'<query xmlns:yahoo="http://www.yahooapis.com/v1/base.rng"
'    yahoo:count="1" yahoo:created="2014-01-22T00:54:50Z" yahoo:lang="en-US">
'    <results>
'        <quote symbol="MSFT">
'            <Ask>36.16</Ask>
'            <AverageDailyVolume>41359300</AverageDailyVolume>
'            <Bid>36.09</Bid>
'            <AskRealtime>36.16</AskRealtime>
'            <BidRealtime>36.09</BidRealtime>
'            <BookValue>9.782</BookValue>
'            <Change_PercentChange>-0.21 - -0.58%</Change_PercentChange>
'            <Change>-0.21</Change>
'            <Commission/>
'            <ChangeRealtime>-0.21</ChangeRealtime>
'            <AfterHoursChangeRealtime>N/A - N/A</AfterHoursChangeRealtime>
'            <DividendShare>0.97</DividendShare>
'            <LastTradeDate>1/21/2014</LastTradeDate>
'            <TradeDate/>
'            <EarningsShare>2.671</EarningsShare>
'            <ErrorIndicationreturnedforsymbolchangedinvalid/>
'            <EPSEstimateCurrentYear>2.66</EPSEstimateCurrentYear>
'            <EPSEstimateNextYear>2.88</EPSEstimateNextYear>
'            <EPSEstimateNextQuarter>0.66</EPSEstimateNextQuarter>
'            <DaysLow>36.06</DaysLow>
'            <DaysHigh>36.82</DaysHigh>
'            <YearLow>27.00</YearLow>
'            <YearHigh>38.98</YearHigh>
'            <HoldingsGainPercent>- - -</HoldingsGainPercent>
'            <AnnualizedGain/>
'            <HoldingsGain/>
'            <HoldingsGainPercentRealtime>N/A - N/A</HoldingsGainPercentRealtime>
'            <HoldingsGainRealtime/>
'            <MoreInfo>cn</MoreInfo>
'            <OrderBookRealtime/>
'            <MarketCapitalization>301.9B</MarketCapitalization>
'            <MarketCapRealtime/>
'            <EBITDA>31.367B</EBITDA>
'            <ChangeFromYearLow>+9.17</ChangeFromYearLow>
'            <PercentChangeFromYearLow>+33.96%</PercentChangeFromYearLow>
'            <LastTradeRealtimeWithTime>N/A - &lt;b&gt;36.17&lt;/b&gt;</LastTradeRealtimeWithTime>
'            <ChangePercentRealtime>N/A - -0.58%</ChangePercentRealtime>
'            <ChangeFromYearHigh>-2.81</ChangeFromYearHigh>
'            <PercebtChangeFromYearHigh>-7.21%</PercebtChangeFromYearHigh>
'            <LastTradeWithTime>Jan 21 - &lt;b&gt;36.17&lt;/b&gt;</LastTradeWithTime>
'            <LastTradePriceOnly>36.17</LastTradePriceOnly>
'            <HighLimit/>
'            <LowLimit/>
'            <DaysRange>36.06 - 36.82</DaysRange>
'            <DaysRangeRealtime>N/A - N/A</DaysRangeRealtime>
'            <FiftydayMovingAverage>37.0421</FiftydayMovingAverage>
'            <TwoHundreddayMovingAverage>34.7513</TwoHundreddayMovingAverage>
'            <ChangeFromTwoHundreddayMovingAverage>+1.4187</ChangeFromTwoHundreddayMovingAverage>
'            <PercentChangeFromTwoHundreddayMovingAverage>+4.08%
'            </PercentChangeFromTwoHundreddayMovingAverage>
'            <ChangeFromFiftydayMovingAverage>-0.8721</ChangeFromFiftydayMovingAverage>
'            <PercentChangeFromFiftydayMovingAverage>-2.35%</PercentChangeFromFiftydayMovingAverage>
'            <Name>Microsoft Corpora</Name>
'            <Notes/>
'            <Open>36.81</Open>
'            <PreviousClose>36.38</PreviousClose>
'            <PricePaid/>
'            <ChangeinPercent>-0.58%</ChangeinPercent>
'            <PriceSales>3.78</PriceSales>
'            <PriceBook>3.72</PriceBook>
'            <ExDividendDate>Nov 19</ExDividendDate>
'            <PERatio>13.62</PERatio>
'            <DividendPayDate>Mar 13</DividendPayDate>
'            <PERatioRealtime/>
'            <PEGRatio>1.93</PEGRatio>
'            <PriceEPSEstimateCurrentYear>13.68</PriceEPSEstimateCurrentYear>
'            <PriceEPSEstimateNextYear>12.63</PriceEPSEstimateNextYear>
'            <Symbol>MSFT</Symbol>
'            <SharesOwned/>
'            <ShortRatio>1.80</ShortRatio>
'            <LastTradeTime>4:00pm</LastTradeTime>
'            <TickerTrend>&nbsp;===+==&nbsp;</TickerTrend>
'            <OneyrTargetPrice>37.01</OneyrTargetPrice>
'            <Volume>31578980</Volume>
'            <HoldingsValue/>
'            <HoldingsValueRealtime/>
'            <YearRange>27.00 - 38.98</YearRange>
'            <DaysValueChange>- - -0.58%</DaysValueChange>
'            <DaysValueChangeRealtime>N/A - N/A</DaysValueChangeRealtime>
'            <StockExchange>NasdaqNM</StockExchange>
'            <DividendYield>2.67</DividendYield>
'            <PercentChange>-0.58%</PercentChange>
'        </quote>
'    </results>
'</query>
    
    Dim oChild As MSXML2.IXMLDOMNode
    Dim sText As String
    
    On Error GoTo HandleErr
    If statusText <> "" Then
        sText = statusText & " - " & QuoteParameter
    Else
        sText = ""
    End If
        
    For Each oChild In stockXml.ChildNodes
        If sText <> "" Then
            Application.StatusBar = sText & " (found " & oChild.nodeName & ")"
        End If
        If oChild.nodeName = QuoteParameter Then
            s = oChild.Text
            GetQuoteFromXml = s
            If sText <> "" Then Application.StatusBar = sText
            Exit Function
        End If
    Next oChild
    If sText <> "" Then Application.StatusBar = sText & " not found!"
        
' error handlers
ExitHere:
            Exit Function
HandleErr:
            MsgBox "GetQuoteFromXml Error " & Err.Number & ": " & Err.Description
            Resume ExitHere
            Resume
End Function

预期的 XML 结构包含作为参考；它让您知道哪些值可用。

这可能会如何使用？假设您的 Excel 工作表中包含以下几行（Excel 2007 屏幕截图）

Excel Worksheet Image

要查询的代码出现在 A 列；唯一看起来不寻常的是 `^GSPC`，这是 Yahoo 用于标准普尔 500 指数的代码。其余列是我想要用实时报价数据填充的列，按需刷新。

上述 VBA 函数的设计方式是这样调用的：

使用 `GetQuoteXmlFromWeb` 加载某只股票的代码数据。
通过多次调用 `GetQuoteFromXML` 从结果中获取所需的报价数据。

这种设计允许为每只股票代码进行一次 Web 服务调用；返回的 Web 数据会保存足够长的时间以提取所有所需信息。重复此过程，直到所有股票代码都被检索和解析。您可以重构代码，让 `GetQuoteXmlFromWeb` 接受多个股票代码，让 `GetQuoteFromXML` 同时接受股票代码和数据值名称。我选择将其拆分是为了简单起见。通过使用宏循环遍历数据表来检索多只股票的数据。

' for all sequential symbols in A2 and on down.
'
' manageCalcStatus = TRUE if we should turn Autocalc off then restore, or FALSE if caller does it
'
Sub UpdatePriceData(Optional manageCalcStatus As Boolean = True)
    Dim stockXml As MSXML2.IXMLDOMNode
    Dim stockData(5) As Double ' Open, High, Low, Current/Close, Volume
    Dim stockDate As Date   ' Last Trade Date
    Dim stockTime As Date   ' Last Trade time
    
    sbState = Application.DisplayStatusBar  ' save current state
    Application.DisplayStatusBar = True     ' take over status bar
    Application.StatusBar = "Preparing quote request..."
 
    If manageCalcStatus Then
        appCalcStatus = Application.Calculation
        Application.Calculation = xlCalculationManual
    End If
    
    ' Activate the sheet and get to the last row
    Sheets("Price Data").Select
    Range("A2").Select
    Selection.End(xlDown).Select
    
    ' Capture the row number, then start the loop
    iRowLast = ActiveCell.Row
    For i = 2 To iRowLast
        ' For each stock row, get the XML data for the stock and write it to the row
        Range("A" & i).Select
        Application.StatusBar = "Get quote for: " & ActiveCell.Value
        Set stockXml = GetQuoteXmlFromWeb(ActiveCell.Value)
        ' test for Nothing
        If stockXml Is Nothing Then
            ' Could not find it -- all 0's and set date to today
            For n = 0 To UBound(stockData) - 1
                stockData(n) = 0
            Next n
            stockDate = Date
            stockTime = 0
        Else
            ' Got the data... get each piece
            stockData(0) = Val(GetQuoteFromXml(stockXml, "Open"))
            stockData(1) = Val(GetQuoteFromXml(stockXml, "DaysHigh"))
            stockData(2) = Val(GetQuoteFromXml(stockXml, "DaysLow"))
            stockData(3) = Val(GetQuoteFromXml(stockXml, "LastTradePriceOnly"))
            stockData(4) = Val(GetQuoteFromXml(stockXml, "Volume"))
            
            stockDate = CDate(GetQuoteFromXml(stockXml, "LastTradeDate"))
            stockTime = TimeValue(GetQuoteFromXml(stockXml, "LastTradeTime"))
            ' Resets status bar text if GetQUoteFromXml was tweaking it
            Application.StatusBar = "Get quote for: " & ActiveCell.Value
        End If
        
        ' Now assign values out to cells the current row (B to F, then G)
        For n = 0 To UBound(stockData) - 1
            Range(Chr(Asc("B") + n) & i).Value = stockData(n)
        Next n
         Range(Chr(Asc("B") + UBound(stockData)) & i).Value = stockDate
         Range(Chr(Asc("B") + 1 + UBound(stockData)) & i).Value = stockTime
    Next i
        
    If manageCalcStatus Then
        Application.StatusBar = "Resetting calculation state..."
        Application.Calculation = appCalcStatus           ' restore calculation mode too
    End If
    Application.StatusBar = False           ' this RESTORES default text to the status bar... honest!
    Application.DisplayStatusBar = sbState  ' return control to original state

End Sub

此宏加载一个名为 `“Price Data”` 的工作表；请将其替换为您想要的任何工作表名称。此工作表应按上述方式布局。循环从第 2 行开始，遍历 A 列中所有连续的代码。我们一边进行，一边更新状态栏，但如果互联网连接速度很快，它会很快完成，除非被自动重新计算（默认情况下，此宏在获取数据时会禁用它）拖慢速度。

每个股票代码都通过 `GetQuoteXmlFromWeb` 运行，如果成功，则将 `Open`（开盘价）、`DaysHigh`（最高价）、`DaysLow`（最低价）、`LastTradePriceOnly`（当前或收盘价，不含时间戳）和 `Volume`（交易量）的值提取到双精度数组 `stockData` 中。请注意，VBA 的 `Val()` 方法用于将返回的文本转换为数字。

还会单独调用以捕获 `LastTradeDate`（使用 `CDate()` 转换）和 `LastTradeTime`（使用 `TimeValue()` 转换），因为这些需要不同的数据类型。然后，我们遍历当前选定行的工作表列（请注意，`Asc(Chr("B") + 0)` 是“B”，`Asc(Chr("B") + 1)` 是“C”等等），依次输出每个值。然后转到下一行。

一旦 `UpdatePriceData()` 完成其循环，B-H 列将包含最新数据，这些数据将以您为这些列选择的任何格式显示。

对于我特定的工作簿，我在第一个工作表中放置了一个按钮，单击该按钮将调用 `UpdatePriceData()`，然后将焦点返回到该初始工作表。

可以下载 VBA 代码，准备导入，下载文件名为 *Quotes.zip*。

关注点

我的工作簿使用当天的几笔计算以及存储在工作簿其他地方的几年历史数据（其他未显示的宏/函数负责根据需要归档每天的数据），然后绘制结果。在我将自动计算控制添加到 `UpdatePriceData()` 之前，我对更新的缓慢速度感到震惊；这促使我添加了状态栏更新文本。一旦我意识到 Excel 在循环中的每个单元格赋值后都在重新计算所有数据（当一次点击 Excel 的“全部刷新”工具栏按钮即可获取所有内容时，这不成问题），我就增加了暂停重新计算的功能。在暂停自动重新计算后，此方法与原始的带有网页查询的工作簿一样快（甚至更快）。

历史

2014 年 3 月 6 日：发布初始版本

在全新的 Excel 2016 安装上进行测试（从 DVD 安装，非 O365 部分）。令我惊讶的是，它无需修改即可正常工作。