Edge
Chrome
Firefox
来jisilu很多年了，给大家贡献一个自己用的基于新浪行情接口和VBA的Excel股票行情抓取模板。Excel模板在本贴附件里面，2017-2023年已经免费分享了5、6年，自现在起，取消免费分享.
一、解决的痛点：
1、自动抓取股票行情，避免手工跟踪股票价格、市值的麻烦。
2、避免股票行情软件花花绿绿的界面（懂得）
3、自定义各种公式
二、主要功能：
1、可获取A股指数、个股、转债、基金、港股（港股有可能是延时的） 行情
2、定时（30秒，可修改）刷新功能
3、增加修改需要关心的个股非常方便（不需要编程能力）
三、应用场景举例
1、持仓市值跟踪：手工在本Excel中输入持仓数量，借助实时行情刷新，可创建自己的实时市值、仓位管理功能。
2、转债溢价率跟踪：抓取转债价格、正股价格，可利用excel功能实时跟踪转债溢价率。
3、分级基金合并溢价跟踪：以上海分级为例，抓取A、B和母鸡价格，可跟踪分级基金合并溢价。
四、安全性
1、VBA代码经本人逐句编写，不含恶意代码。
五、运行条件：
1、Excel上要开放“宏”运行权限（一般性Excel会有提示）
2、版本问题申明：在本人Office家庭和学生版Excel上运行正常，本人WPS版本上运行正常。
六、免责声明
1、本excel免费使用，本人不承担因使用、复制、传播此excel及其相关功能造成的任何损失
2、由于使用者电脑设置及excel软件版本，可能造成运行不正常，此问题我无法控制，只能用户自行解决。从实际大约50+用户反馈来看，反映无法正常运行的用户极少（少于5%）
七、（关闭下载）下载链接（目前关闭下载，敬请期待）
**1、本人提供的模板仅为个人之间学习使用，不允许用于商业用途，交付后不承诺任何后续技术支持服务，也不接受退款，不对后续使用赴任何责任。 2、目前关闭下载，正在计划对抓取模板进行升级，增加更多功能和场景，敬请期待。
-------------------------
历史变更记录：
20220121新浪接口变更，紧急消缺更新到4.0版本
20230730 取消免费分享
20230812公告 。感谢各位的关注，由于收到jisilu后台提醒“请不要在社区做任何形式的营销推广”，出于对jisilu的尊重，即日起停止在本贴分享行情抓取模板的下载链接。各位朋友若确有需要，可以pm联系沟通
自己用的，所以比较简陋。如有不明，可回帖或私信联系。
致谢：
1、这个方法参考了jisilu里面很多同学的帖子，特别感谢islq同学在https://www.jisilu.cn/question/2230帖子里面提供的excel样例.
2、致谢20220121 欣财富自由之路@jisilu网友提供的新浪接口修复代码
一、解决的痛点：
1、自动抓取股票行情，避免手工跟踪股票价格、市值的麻烦。
2、避免股票行情软件花花绿绿的界面（懂得）
3、自定义各种公式
二、主要功能：
1、可获取A股指数、个股、转债、基金、港股（港股有可能是延时的） 行情
2、定时（30秒，可修改）刷新功能
3、增加修改需要关心的个股非常方便（不需要编程能力）
三、应用场景举例
1、持仓市值跟踪：手工在本Excel中输入持仓数量，借助实时行情刷新，可创建自己的实时市值、仓位管理功能。
2、转债溢价率跟踪：抓取转债价格、正股价格，可利用excel功能实时跟踪转债溢价率。
3、分级基金合并溢价跟踪：以上海分级为例，抓取A、B和母鸡价格，可跟踪分级基金合并溢价。
四、安全性
1、VBA代码经本人逐句编写，不含恶意代码。
五、运行条件：
1、Excel上要开放“宏”运行权限（一般性Excel会有提示）
2、版本问题申明：在本人Office家庭和学生版Excel上运行正常，本人WPS版本上运行正常。
六、免责声明
1、本excel免费使用，本人不承担因使用、复制、传播此excel及其相关功能造成的任何损失
2、由于使用者电脑设置及excel软件版本，可能造成运行不正常，此问题我无法控制，只能用户自行解决。从实际大约50+用户反馈来看，反映无法正常运行的用户极少（少于5%）
七、（关闭下载）下载链接（目前关闭下载，敬请期待）
**1、本人提供的模板仅为个人之间学习使用，不允许用于商业用途，交付后不承诺任何后续技术支持服务，也不接受退款，不对后续使用赴任何责任。 2、目前关闭下载，正在计划对抓取模板进行升级，增加更多功能和场景，敬请期待。
-------------------------
历史变更记录：
20220121新浪接口变更，紧急消缺更新到4.0版本
20230730 取消免费分享
20230812公告 。感谢各位的关注，由于收到jisilu后台提醒“请不要在社区做任何形式的营销推广”，出于对jisilu的尊重，即日起停止在本贴分享行情抓取模板的下载链接。各位朋友若确有需要，可以pm联系沟通
自己用的，所以比较简陋。如有不明，可回帖或私信联系。
致谢：
1、这个方法参考了jisilu里面很多同学的帖子，特别感谢islq同学在https://www.jisilu.cn/question/2230帖子里面提供的excel样例.
2、致谢20220121 欣财富自由之路@jisilu网友提供的新浪接口修复代码
0
楼主及众集友：
我很喜欢这样的适用工具，适用并添加了自己关注的股票。
但是有没有遇到同样问题的，windows10提示木马病毒，trojan:script/oneeva.a!ml。最近己次反复删除。
不知道是否真的病毒，哪个环节感染到病毒。
我下载后，自己另起一页遍了一些简单的公式，提示自己关注的股票分位值。
我很喜欢这样的适用工具，适用并添加了自己关注的股票。
但是有没有遇到同样问题的，windows10提示木马病毒，trojan:script/oneeva.a!ml。最近己次反复删除。
不知道是否真的病毒，哪个环节感染到病毒。
我下载后，自己另起一页遍了一些简单的公式，提示自己关注的股票分位值。
0
大神可以帮忙看看这个怎么添加一个30秒自动更新，麻烦了
Function FillOneRow(url As String, r As Integer) As Integer
With CreateObject("msxml2.xmlhttp")
.Open "GET", url, False
.send
sp = Split(.responsetext, "~")
If UBound(sp) > 3 Then
FillOneRow = 1
Cells(r, 2).Value = sp(1) '名称
Cells(r, 3).Value = sp(3) '当前价格
Cells(r, 4).Value = sp(4) '昨日收盘价
Dim zhangDie As Double
zhangDie = sp(32)
Cells(r, 5).Value = zhangDie
If zhangDie > 0 Then
'上涨使用红色
Cells(r, 5).Font.Color = vbRed
Cells(r, 3).Font.Color = vbRed
Else
'下跌使用绿色
Cells(r, 5).Font.Color = &H228B22
Cells(r, 3).Font.Color = &H228B22
End If
Else
FillOneRow = 0
End If
End With
End Function
Sub GetData()
Application.ScreenUpdating = False
Dim succeeded As Integer
Dim url As String
Dim row As Integer
Dim code As String
For row = 2 To Range("A1").CurrentRegion.Rows.Count '从第二行开始
code = Cells(row, 1).Value
If code = "000001" Then
url = "http://qt.gtimg.cn/q=sh" & code '沪市
succeeded = FillOneRow(url, row)
End If
Next
For row = 3 To Range("A1").CurrentRegion.Rows.Count '从第三行开始
code = Cells(row, 1).Value
If code <> "" Then
url = "http://qt.gtimg.cn/q=sz" & code '深市
succeeded = FillOneRow(url, row)
If succeeded = 0 Then
url = "http://qt.gtimg.cn/q=sh" & code '沪市
succeeded = FillOneRow(url, row)
End If
If succeeded = 0 Then
MsgBox ("获取失败")
End If
End If
Next
Application.ScreenUpdating = True
End Sub
Function FillOneRow(url As String, r As Integer) As Integer
With CreateObject("msxml2.xmlhttp")
.Open "GET", url, False
.send
sp = Split(.responsetext, "~")
If UBound(sp) > 3 Then
FillOneRow = 1
Cells(r, 2).Value = sp(1) '名称
Cells(r, 3).Value = sp(3) '当前价格
Cells(r, 4).Value = sp(4) '昨日收盘价
Dim zhangDie As Double
zhangDie = sp(32)
Cells(r, 5).Value = zhangDie
If zhangDie > 0 Then
'上涨使用红色
Cells(r, 5).Font.Color = vbRed
Cells(r, 3).Font.Color = vbRed
Else
'下跌使用绿色
Cells(r, 5).Font.Color = &H228B22
Cells(r, 3).Font.Color = &H228B22
End If
Else
FillOneRow = 0
End If
End With
End Function
Sub GetData()
Application.ScreenUpdating = False
Dim succeeded As Integer
Dim url As String
Dim row As Integer
Dim code As String
For row = 2 To Range("A1").CurrentRegion.Rows.Count '从第二行开始
code = Cells(row, 1).Value
If code = "000001" Then
url = "http://qt.gtimg.cn/q=sh" & code '沪市
succeeded = FillOneRow(url, row)
End If
Next
For row = 3 To Range("A1").CurrentRegion.Rows.Count '从第三行开始
code = Cells(row, 1).Value
If code <> "" Then
url = "http://qt.gtimg.cn/q=sz" & code '深市
succeeded = FillOneRow(url, row)
If succeeded = 0 Then
url = "http://qt.gtimg.cn/q=sh" & code '沪市
succeeded = FillOneRow(url, row)
End If
If succeeded = 0 Then
MsgBox ("获取失败")
End If
End If
Next
Application.ScreenUpdating = True
End Sub
2
赞同来自: 繁星6165 、wangliang99
不绑定手机还评论不了，为了谢谢博主，特意绑定啦手机
非常感谢，这是我一直想要的功能，而且可以取到场外的指数基金净值，棒棒哒
场外基金的净值取到的是累计净值，略微改了一下就可以取单位净值啦
非常好用，多谢多谢
非常感谢，这是我一直想要的功能，而且可以取到场外的指数基金净值，棒棒哒
场外基金的净值取到的是累计净值，略微改了一下就可以取单位净值啦
非常好用，多谢多谢
0
得到楼主的启发，前面的贴都已经利用上了，做成了自动获取每日价格的表格。
但是在考虑结合估值数据做价值均衡策略的自动计算定投金额，所以要用到表格里每日自动获取指数的PE和PB。
有没有人懂的，来谈一下？？？
但是在考虑结合估值数据做价值均衡策略的自动计算定投金额，所以要用到表格里每日自动获取指数的PE和PB。
有没有人懂的，来谈一下？？？
9
赞同来自: dongqingshun 、四季0432 、阿良 、木奉木奉米唐 、zg2000sh 、 、 、 、更多 »
我把自动更新flitter银行股轮动数据工具中用到的提取行情的代码贴一下吧，可以更新港股和A股，具体表格结构见flitter原帖界面动画截图，根本不应该卡的。
真正获取行情的部分从：'获得查询url的股票list开始，直到Range("汇率") = ExchRate之间部分
真正获取行情的部分从：'获得查询url的股票list开始，直到Range("汇率") = ExchRate之间部分
'更新当前价格价格数据（昨收、现价）
Sub upDateCurHq()
Dim orgCode As String, dataGot, dataSplit
Dim itemCount As Byte, hkCount As Byte
Dim i As Byte, ExchRate As Double
Dim urlList As String
Dim NetStatus As Integer
Dim arrHisData() As Double
' Application.ScreenUpdating = False
Sheets("flitter").Activate
ExchRate = NetOk
If ExchRate < 0 Then Exit Sub
With CreateObject("MSXML2.XMLHTTP")
.Open "Get", "http://hq.sinajs.cn/?list=h_RMBHKD", False
.Send
ExchRate = Split(.responseText, ",")(4) / 100
End With
i = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
Range("I5", Cells(i, 10)).ClearContents
[I4] = "昨收"
[J4] = "现价"
'按代码类别排序股票
With ActiveSheet.AutoFilter.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("B4"), Order:=xlAscending
.Apply
End With
'查询RMB对HKD的汇率
hkCount = 0
itemCount = Sheets("flitter").Cells(Rows.Count, 2).End(xlUp).Row '最下面的股票代码所在行号
If itemCount <= 5 Then Exit Sub
'获得查询url的股票list
For i = 5 To itemCount
orgCode = LCase(Cells(i, 2))
If Left(orgCode, 2) = "hk" Then
orgCode = "rt_hk" & Right(orgCode, 5)
hkCount = hkCount + 1
End If
urlList = urlList & "," & orgCode
Next i
'获得所有股票行情数据
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "http://hq.sinajs.cn/list=" & Right(urlList, Len(urlList) - 1), False
.Send
dataGot = Split(.responseText, """;" & Chr(10))
End With
'获取港股昨收价和现价
For i = 5 To hkCount + 4
dataSplit = Split(dataGot(i - 5), ",")
With Sheets("flitter")
.Cells(i, 9) = Round(dataSplit(3) * ExchRate, 3) '昨收价-港股
.Cells(i, 10) = Round(dataSplit(6) * ExchRate, 3) '现价-港股
' .Cells(i, 14) = .Cells(i, 14) / Range("汇率") * ExchRate '参照日价格按汇率变化进行调整
End With
Next i
'获取A股昨收价和现价
For i = hkCount + 5 To itemCount
dataSplit = Split(dataGot(i - 5), ",")
With Sheets("flitter")
.Cells(i, 9) = Round(dataSplit(2), 3) '昨收价 - A股
.Cells(i, 10) = Round(dataSplit(3), 3) '现价 - A股
End With
Next i
Range("汇率") = ExchRate
'恢复按flitter提供顺序排序
With ActiveSheet.AutoFilter.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("A4"), Order:=xlAscending
.Apply
End With
End Sub 
京公网安备 11010802031449号