谁说Excel不能做爬虫，基金监控助手——VBA版

2014晴天

之前回复坛友股票监控的帖子只是一时兴起，没想到后来有位小伙伴私信我，问能不能搞一个基金监控的

中午看了下接口和数据就趁着午休（我才不是一个上班划水的小机灵鬼）大概搞了下，主要就用到了msxml2.xmlhttp和vbscript.regexp这俩库（姑且让我这么称呼他俩吧）


功能很简单，就是看一些基础的资料，再次要特别感谢接口无偿提供者@小熊同学，为数据预处理省了很多功夫，好啦，废话不多说，下面看代码吧！


哦，不对，还要上个演示图才对。

[Python] 纯文本查看 复制代码

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" & .[a65536].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晴天

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

价值投机

前排支持，多谢多谢。

pc2k007

感谢楼主分享！！！

616666920

哇,这个我需要..太感谢了.

zxinyun

还是要有个稳定靠谱的接口才行

qdhjysd

感谢楼主分享！！！

shenjfun

谢谢分享！

、﹏尐酒窩づ

听起来非常厉害

616666920

单位净值日涨幅数据是不是有问题

616666920

是数据源有问题还是计算逻辑有问题, 日涨幅超过100%