VBA网爬+股票查询

WatchChen · 发表于 2019-9-24 15:56

嗯~ o(*￣▽￣*)o，在某论坛看到一位老哥发了一个股票爬取文件

忍不住就下载下来自己改了改，相对于其单元格的操作我JIO的数组还是快一点儿吧

不过运行了一下感觉还是很慢，不知道是不是msxml2.xmlhttp这个的问题

所以想来问一下，不知道可不可以再加优化一下速度！

下面附上老哥原码和我改的以及文件。

‘这个是老哥的原码
Sub GET_STOCK()
'-------------Clean old data--------------------------------
Dim bb%, aa%
aa = [d1048576].End(xlUp).row
bb = [b1048576].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

复制代码

’这儿是我改的
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

复制代码

leeyes · 发表于 2019-9-24 19:04

运行时提示“下标越界”是什么意思啊？

我在天外 · 发表于 2019-9-24 20:02

本帖最后由我在天外于 2019-9-24 20:12 编辑

循环使用msxml2.xmlhttp去请求，满在这块了。感觉用vb做异步多线程去实现，有点太过折腾了。

看到以前有人发过帖：http://club.excelhome.net/forum.php?mod=viewthread&tid=1397922