Excel也爬虫，股票监控助手 1.1
最近上班无聊，但是又不敢大张旗鼓打开浏览器去看股票，于是在Excel里弄了个股票监控小助手，老板还以为我在认真分析数据{:1_918:}
[*]希望有大佬可以继续深入优化一下，添加多一些功能，目前只是简单的涨跌
另外，请教各路大神，关于在同一个Class下面，有多项<tr>信息，我应该如何分开抓取信息？
使用方法：
在A列输入你的股票代码，然后点击按钮更新即可
系统:Win10 64
OFFICE 365测试使用正常
希望大家鼓励支持一下！！
觉得有用，请给个免费评分 ，谢谢！
源码分享：
Sub GET_STOCK()
'-------------Clean old data--------------------------------
Dim bb%, aa%
aa = .End(xlUp).row
bb = .End(xlUp).row
Range("b3:r3" & bb).ClearContents
'--------------data update time-------------------------------
Range("B1") = Format(Now, "mm-dd / hh:mm:ss") 'update time
'---------------judge stock of SH or SZ------------------------------
For r = 3 To Range("A1").CurrentRegion.Rows.Count
dm = Cells(r, 1).Value
If left(dm, 1) = 6 Or dm = "000001" Then
url = "http://qt.gtimg.cn/q=sh" & dm 'Shanghai stock
Else
url = "http://qt.gtimg.cn/q=sz" & dm 'Shenzhen stock
End If
With CreateObject("msxml2.xmlhttp")
.Open "GET", url, False
.send
sp = Split(.responseText, "~")
If UBound(sp) > 3 Then
'---------------get data part------------------------------
Cells(r, 2).Value = sp(1) 'Name
Cells(r, 3).Value = sp(3) 'Current Price
Cells(r, 5).Value = sp(32) 'Up down %
Cells(r, 6).Value = sp(4) 'Yesterday Price
Cells(r, 7).Value = sp(5) 'Opening price
Cells(r, 8).Value = sp(33) 'Highest
Cells(r, 9).Value = sp(34) 'Minimum
Cells(r, 10).Value = sp(47) 'Harden price
Cells(r, 11).Value = sp(48) 'Drop stop price
Cells(r, 12).Value = sp(38) 'Turnover rate
Cells(r, 13).Value = sp(43) 'Amplitude
Cells(r, 14).Value = sp(6) 'Trading volume
Cells(r, 15).Value = sp(39) 'P/e ratio
Cells(r, 16).Value = sp(44) 'Current market
Cells(r, 17).Value = sp(45) 'Total market value
Cells(r, 18).Value = sp(46) 'price-to-book
'---------------Up or Down color------------------------------
Dim zhangDie As Double
zhangDie = sp(31)'up down price
Cells(r, 4).Value = zhangDie'up down price
If zhangDie > 0 Then
Cells(r, 4).Font.Color = vbRed
Cells(r, 5).Font.Color = vbRed
Else
Cells(r, 4).Font.Color = &H228B22
Cells(r, 5).Font.Color = &H228B22
End If
Else
End If
End With
Next
End Sub
嗯~ o(*￣▽￣*)o，希望楼主不要介意，用数组写了下，应该比直接操作单元格快一点儿吧...
Option Explicit
Sub emmmm()
Dim nR%, r%, dm$, url$, t
Dim arr, ssr
t = Timer
Application.ScreenUpdating = False
'==================================================================
With Sheet3
arr = .Range("a1").CurrentRegion
arr(1, 2) = Format(Now, "mm-dd") '更新时间
arr(1, 3) = Format(Now, "hh:mm")
For r = 3 To UBound(arr)
dm = arr(r, 1)
If left(dm, 1) = 6 Or dm = "000001" Then
url = "http://qt.gtimg.cn/q=sh" & dm '上交所
Else
url = "http://qt.gtimg.cn/q=sz" & dm '深交所
End If
With CreateObject("msxml2.xmlhttp")
.Open "GET", url, False
.send
ssr = Split(.responseText, "~")
If UBound(ssr) > 3 Then
arr(r, 2) = ssr(1): arr(r, 3) = ssr(3): arr(r, 5) = ssr(32): arr(r, 6) = ssr(4)
arr(r, 7) = ssr(5): arr(r, 8) = ssr(33): arr(r, 9) = ssr(34): arr(r, 10) = ssr(47)
arr(r, 11) = ssr(48): arr(r, 12) = ssr(38): arr(r, 13) = ssr(43): arr(r, 14) = ssr(6)
arr(r, 15) = ssr(39): arr(r, 16) = ssr(44): arr(r, 17) = ssr(45): arr(r, 18) = ssr(46)
arr(r, 4) = ssr(31)
If arr(r, 4) > 0 Then
With Range("d" & r & ":e" & r).Font
.Color = vbRed
.Bold = True
End With
Else
With Range("d" & r & ":e" & r).Font
.Color = vbGreen
.Bold = True
End With
End If
End If
End With
Next
.Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
End With
Application.ScreenUpdating = True
MsgBox "又赚了一个亿呀，仅耗时：" & Format(Timer - t, "0.00秒"), 64, "WatchMen温馨提示："
End Sub
omy2000 发表于 2020-3-12 08:47
office2010报错，找不到数据
报错估计是你的office问题，截图看看 差600CB改名字，好惨 沙发，感谢分享 感谢分享{:1_927:} 牛逼啊!!! python re模块 这个有点厉害啦，手机看看就可以了 感谢楼主分享 这个有意思哈
厉害厉害 可惜不懂股票