Excel也爬虫，股票监控助手 1.1

文西思密达

最近上班无聊，但是又不敢大张旗鼓打开浏览器去看股票，
于是在Excel里弄了个股票监控小助手，老板还以为我在认真分析数据

• 希望有大佬可以继续深入优化一下，添加多一些功能，目前只是简单的涨跌
  

另外，请教各路大神，关于在同一个Class下面，有多项<tr>信息，我应该如何分开抓取信息？


使用方法：
在A列输入你的股票代码，然后点击按钮更新即可



系统:Win10 64
OFFICE 365测试使用正常



希望大家鼓励支持一下！！
觉得有用，请给个免费评分 ，谢谢！


Stock 1.1.rar (22.75 KB, 下载次数: 2997)

2019-4-16 09:37 上传

点击文件名下载附件
下载积分: 吾爱币 -1 CB

源码分享：

[Visual Basic] 纯文本查看 复制代码

 
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

2014晴天

嗯~ o(*￣▽￣*)o，希望楼主不要介意，用数组写了下，应该比直接操作单元格快一点儿吧...

[Visual Basic] 纯文本查看 复制代码

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改名字，好惨

dedegoodboy

沙发，感谢分享

xk8899

感谢分享

tianlanghd

牛逼啊!!!

GhostCN_Z

python re模块

f23258

这个有点厉害啦，手机看看就可以了

liurunpeng

感谢楼主分享

坐久落花多

这个有意思哈

花心乞丐

厉害厉害 可惜不懂股票