谁说Excel不能做爬虫，基金监控助手——VBA版
之前回复坛友股票监控的帖子只是一时兴起，没想到后来有位小伙伴私信我，问能不能搞一个基金监控的中午看了下接口和数据就趁着午休（我才不是一个上班划水的小机灵鬼）大概搞了下，主要就用到了msxml2.xmlhttp和vbscript.regexp这俩库（姑且让我这么称呼他俩吧）
功能很简单，就是看一些基础的资料，再次要特别感谢接口无偿提供者@小熊同学，为数据预处理省了很多功夫，好啦，废话不多说，下面看代码吧！
哦，不对，还要上个演示图才对。
Option Explicit
Sub Fund()
Dim i%, j%, url$, res$, m, t
Dim arr, mat
t = Timer
Application.ScreenUpdating = False
'==================================================================
With Sheet3
arr = .Range("a5:u" & ..End(3).Row())
For i = 1 To UBound(arr)
url = "https://api.doctorxiong.club//v1/fund?code=" & arr(i, 1)
arr(i, 1) = "'" & arr(i, 1)
With CreateObject("msxml2.xmlhttp")
.Open "GET", url, False
.send
res = .responseText
End With
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = ":\" & Chr(34) & "(.+?)\" & Chr(34) & "|:(\d.+?),"
Set mat = .Execute(res)
End With: j = 1
For Each m In mat
If j = 2 Then
If m.SubMatches(0) <> "操作成功" Then
MsgBox "接口限制，过几分钟再来查一下吧！", 64, "WatchMen温馨提示"
Exit Sub
End If
ElseIf j > 3 Then
arr(i, j - 2) = IIf(m.SubMatches(0) = "", m.SubMatches(1), m.SubMatches(0))
End If: j = j + 1
Next
Next
.Range("a5").Resize(UBound(arr), UBound(arr, 2)) = arr
End With
Application.ScreenUpdating = True
MsgBox "又赚了一个亿呀，仅耗时：" & Format(Timer - t, "0.00秒"), 64, "WatchMen温馨提示："
End Sub
本帖最后由 2014晴天 于 2020-6-3 16:52 编辑
gaoxiaoao 发表于 2020-6-3 16:34
可以，直接网页爬的话v还是python吧，这个太弱了
工具没有强弱，人才有，大佬可以分享一下自己的python代码给我等学习哈！ 请教楼主个问题,我从网上找到一个excel表格统计股票交易的,但是里面牵扯到价格自动更新的出了问题
http://qt.gtimg.cn/q=sz接口的网站,可以在网页看到正常更新数据,但是在n = rst.RecordCount这个地方提示编译错误,提示类型不匹配
跪谢啊,对这类excel函数完全不懂
Sub 持仓更新()
On Error Resume Next
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim i, j, m, n As Integer
Dim ny, nn, yy
Dim r, r1, l, l1 As Long
Dim xrg As Range, xaddress
Dim URL, Temp, arr, dm, df
r = Sheets("交易流水").Range("a" & Rows.Count).End(xlUp).Row
l = Sheets("交易流水").Cells(1, Columns.Count).End(xlToLeft).Column
r1 = Range("b" & Rows.Count).End(xlUp).Row
l1 = Cells(2, Columns.Count).End(xlToLeft).Column
If r1 > 10 Then Range(Cells(11, 2), Cells(r1, 5)).ClearContents
Set xrg = Sheets("交易流水").Range("a1").Resize(r, l)
xaddress = xrg.Address(0, 0)
Set conn = New ADODB.Connection
Set rst = New ADODB.Recordset
conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & ThisWorkbook.FullName
strsql = "select distinct 账户,代码,名称 from [交易流水$" & xaddress & "] where 代码 is not null order by 账户,代码"
rst.Open strsql, conn, adOpenKeyset, adLockOptimistic
n = rst.RecordCount
m = rst.Fields.Count
If n = 0 Then GoTo 1
ReDim arr(1 To n, 1 To m + 2)
For i = 1 To n
For j = 1 To m
arr(i, j) = rst.Fields(j - 1)
Next j
rst.MoveNext
Next i
Temp = CreateObject("Wscript.shell").Run("ping qt.gtimg.cn -n 1", 0, True)
If Temp <> 0 Then
MsgBox "没有更新最新价，请检查网络是否通畅！", , qymc & "-系统提示"
Range("b11").CopyFromRecordset rst
Else
For i = 1 To n
dm = arr(i, 2)
If Left(Val(dm), 2) = 60 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
df = Split(.responsetext, "~")
End With
If df(3) = 0 Then
arr(i, 4) = df(4)
arr(i, 5) = df(4)
Else
arr(i, 4) = df(3)
arr(i, 5) = df(4)
End If
Next i
Range("b11").Resize(n, 5) = arr
' Range("c11:c" & 11 + n).NumberFormatLocal = "'" & "@"
End If
With ActiveSheet.PageSetup
.TopMargin = 6
.LeftMargin = 3
.RightMargin = 3
.HeaderMargin = 3
.FooterMargin = 3
.Orientation = 2 'xlLandscape
.CenterHorizontally = True
.CenterVertically = False
.PrintArea = Range(Cells(1, 2), Cells(n + 10, l1)).Address
.Zoom = Sheets("基础资料").Range("a7").Value
End With
1:
conn.Close
Set rst = Nothing
Set conn = Nothing
0:
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Sub
End Sub 前排支持，多谢多谢。 感谢楼主分享！！！ 哇,这个我需要..太感谢了. 还是要有个稳定靠谱的接口才行 感谢楼主分享！！！ 谢谢分享！ 听起来非常厉害 单位净值日涨幅数据是不是有问题 是数据源有问题还是计算逻辑有问题, 日涨幅超过100%