用Excel做一个实时股票行情看板看五档行情联动公式

最近因为股票盯盘需要，又不想开着专业的软件（不方便上班摸鱼），就用excel做了个盯盘表格，可以关联公式，这样达到自己的价格后也可以自定义提醒。先看下效果：Excel股票五档盘口实时行情数据及当日成交明细下载器演示视频_哔哩哔哩_bilibili

大概的界面还是挺简单的，就一页表格：左边控制刷新频率和股票，中间是刷新的数据，右边是同步刷新的成交明细。另外还做了个在线浏览的按钮，可以看筹码分布。应该说对于快速看盘，不花时间的那种来说已经够用了。

 

以上是用筹码浏览器自动打开的页面。

这里放下五档行情的代码给大家看下吧，剩余成交明细的代码大家可以去B站演示视频简介里面的链接获取。 

Sub Get5PriceData()

Dim SalePriceAmountArray(1 To 5, 1 To 2) As Variant
Dim BuyPriceAmountArray(1 To 5, 1 To 2) As Variant
Dim SaleAmount As Double, BuyAmout As Double
Dim BuyToSalePercent As Double, BuyToSaleDif As Double
Dim QuoteDataArray(1 To 25) As Variant
Dim StockCode As String
DoEvents
ThisWorkbook.Worksheets("即时看板").Range("D2:E15").ClearContents
ThisWorkbook.Worksheets("即时看板").Range("D18:D41").ClearContents

 StockCode = ThisWorkbook.Worksheets("即时看板").Range("A2").Text
    Select Case Left(StockCode, 1)
        Case "0", "3"
        CodeTittle = "0."
        Case "6"
        CodeTittle = "1."
        Case Else
        CodeTittle = "bj"
        MsgBox "目前本软件不支持北京交易所！"
        Exit Sub
    End Select
    StockCode = CodeTittle & StockCode
    
'Dim UserAgentArray() '反爬使用的UserAgent序列
'ReDim Preserve UserAgentArray(Worksheets("辅助信息").Range("A1048576").End(xlUp).Row - 2)
'For q = 0 To UBound(UserAgentArray)
'UserAgentArray(q) = Worksheets("辅助信息").Range("A" & (q + 2)).Value
'Next

TimeEach = Timer

url = "http://push2delay.eastmoney.com/api/qt/stock/get?fltt=2&invt=2&fields=f43,f44,f45,f46,f47,f48,f49,f50,f51,f52,f55,f58,f60,f71,f84,f85,f92,f116,f117,f127,f161,f162,f163,f164,f167,f168,f173,f191,f192,f530&secid=" & StockCode
        With CreateObject("Winhttp.WinHttpRequest.5.1")
                    .Open "GET", url, True
                    '.SetRequestHeader "User-Agent", UserAgentArray(Int(Rnd() * UBound(UserAgentArray)) + 1), "referer", "https://finance.sina.com.cn/realstock/company/" & StockCode & "/nc.shtml"
                    .send
                    .waitForResponse
                    Do Until .StatusText = "OK" Or .StatusText = "200" 'Winhttp返回的状态正常的状态码一般为200或者OK，具体需要测试阶段针对每个网页来判断
                    DoEvents
                    If Timer - TimeEach > 2 Then Exit Do '这个是检测超时（网页无响应），最多运行2秒后退出
                    Loop
                Dim mystr As String
                mystr = .responseText
        End With
'   Open ThisWorkbook.Path & "\" & "测试.txt" For Binary Access Write As #1
'    Put #1, , mystr
'    Close #1
  Dim Result As Object
      Dim RegExpression As Object
        Set RegExpression = CreateObject("VBScript.RegExp")
           With RegExpression
           .ignorecase = True