ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 1599|回复: 1

[分享] 如何用Excel VBA实现多线程

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-3-19 23:24 | 显示全部楼层 |阅读模式
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
VBA也能实现多线程?这个似乎有点不可思议。现在就给大家介绍一种可以实现多线程的方法。比如我们以爬虫为例,现在我们要通过多线程爬取安居客的房源信息。你会发现多线程的速度会快很多。

Private tparr, arr(13)  '声明这两个变量为了用于错误处理

Public Function s() As Object   '这一句必须写用于引用sqlcel函数
    Set s = Application.COMAddIns("SqlCelAddIn").Object
End Function

'**********多线程爬取(速度更快)
Sub AnjukeCrawMultiThread()
    Range("a1:n1") = Array("城市", "区", "镇", "地址", "小区", "建造日期", "房型", "楼层", "面积", "特点", "总价", "单价", "业主", "描述")
    Dim pg As Integer
    Dim arr() '定义一个Variant类型的数组
    For pg = 1 To 10
        ReDim Preserve arr(pg - 1)
        arr(pg - 1) = Array("getNodes", pg) '数组的每个元素仍是数组,子数组的第一个元素为需要引用的过程/函数名,其它元素依次为传入的参数
    Next pg
    s.multithread arr, True   '调用多线程函数
End Sub


'*********单线程爬取(容易控制)
Sub AnjukeCrawSingleThread()
    Range("a1:n1") = Array("城市", "区", "镇", "地址", "小区", "建造日期", "房型", "楼层", "面积", "特点", "总价", "单价", "业主", "描述")
    Dim pg As Integer
    For pg = 1 To 5
        Call getNodes(pg)
    Next pg
End Sub

'通过标签绝对地址爬虫是sqlcel函数的标志
Sub getNodes(pg As Integer)
    Dim doc As Variant, bfstr As String, lastR As Long, i As Integer
    Dim tpnode As String, tpstr As String, url As String
    url = "https://shanghai.anjuke.com/sale/pudong/p"
    bfstr = "/html[1]/body[1]/div[1]/div[2]/div[4]/ul[1]/"  '通过标签路径获取标签
    Set doc = s.getdoc(url & pg)
    Erase arr()
    For i = 1 To 60
        arr(0) = "上海"
        tpstr = s.getnode(doc, bfstr & "li[" & i & "]/div[2]/div[3]")
        tparr = Split(tpstr, "-")
        arr(1) = tparr(0)
        tryArr1
        arr(2) = tparr(1)
        tryArr3
        arr(4) = Split(tparr(0), " ")(0)
        arr(5) = s.getnode(doc, bfstr & "li[" & i & "]/div[2]/div[2]/span[4]")
        arr(6) = s.getnode(doc, bfstr & "li[" & i & "]/div[2]/div[2]/span[1]")
        arr(7) = s.getnode(doc, bfstr & "li[" & i & "]/div[2]/div[2]/span[3]")
        arr(8) = s.getnode(doc, bfstr & "li[" & i & "]/div[2]/div[2]/span[2]")
        arr(9) = s.getnode(doc, bfstr & "li[" & i & "]/div[2]/div[4]")
        arr(10) = s.getnode(doc, bfstr & "li[" & i & "]/div[3]/span[1]")
        arr(11) = s.getnode(doc, bfstr & "li[" & i & "]/div[3]/span[2]")
        arr(12) = s.getnode(doc, bfstr & "li[" & i & "]/div[2]/div[2]/span[5]")
        tryArr12
        arr(13) = s.getnode(doc, bfstr & "li[" & i & "]/div[2]/div[1]/a[1]")
        lastR = Cells(1048576, 1).End(xlUp).Row + 1
        Range("A" & lastR & ":N" & lastR).Value = arr
    Next i
    lastR = Cells(1048576, 1).End(xlUp).Row + 1
    Range("A" & lastR).Select
    DoEvents
End Sub

'错误处理,可实现类似Try-Catch的错误处理方法
Sub tryArr1()
    On Error GoTo line   '这一句必须,用于捕捉异常
    arr(1) = Split(tparr(0), ";")(2)
    Exit Sub  '这一句必须,表示没有异常退出过程
line:   '这一句必须表示出现异常后需执行的语句
    arr(1) = ""
End Sub

Sub tryArr12()
    On Error GoTo line
    arr(12) = Split(arr(12), ";")(1)
    Exit Sub
line:
    arr(12) = ""
End Sub

Sub tryArr3()
    On Error GoTo line
    arr(3) = tparr(2)
    Exit Sub
line:
    arr(3) = ""
End Sub


需要注意的是使用该方法需要引用一个excel插件sqlcelfuncs,该插件免费且无需联网可实现许多VBA做不到或者做起来很麻烦的事情。具体可参照
https://sqlcel.com/sqlcelfuncs/

评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-4-28 22:55 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
Private arr1 As String, tparr, d As Object, arr(13), doc As Variant

Public Function s() As Object
    Set s = Application.COMAddIns("SqlCelAddIn").Object
End Function

Sub WebCraw()
    Dim pg As Integer, i As Integer, zoneKeys()
    Call DefineDic
    zoneKeys = d.keys
    For i = 0 To UBound(zoneKeys)
        Worksheets.Add after:=Worksheets(Worksheets.Count)
        Range("a1:n1") = Array("城市", "区", "镇", "地址", "小区", "建造日期", "房型", "楼层", "面积", "特点", "总价", "单价", "业主", "描述")
        ActiveSheet.Name = d(zoneKeys(i))
        For pg = 1 To 50
            Call getNodes(pg, zoneKeys(i))
        Next pg
    Next i
End Sub

Sub getNodes(pg As Integer, thezone)
    Dim bfstr As String, lastR As Long, i As Integer
    Dim tpnode As String, tpstr As String, url As String
    url = "https://shanghai.anjuke.com/sale/" & thezone & "/p"
    bfstr = "/html[1]/body[1]/div[1]/div[2]/div[4]/ul[1]/"
    Set doc = s.getdoc(url & pg)
    Erase arr()
    For i = 1 To 60
        arr(0) = "上海"
        tpstr = GettheNode(bfstr & "li[" & i & "]/div[2]/div[3]")
        tparr = Split(tpstr, "-")
        arr1 = tparr(0)
        arr(1) = tryM1
        arr(2) = tparr(1)
        arr(3) = tryM3
        arr(4) = Split(tparr(0), " ")(0)
        arr(5) = GettheNode(bfstr & "li[" & i & "]/div[2]/div[2]/span[4]")
        arr(6) = GettheNode(bfstr & "li[" & i & "]/div[2]/div[2]/span[1]")
        arr(7) = GettheNode(bfstr & "li[" & i & "]/div[2]/div[2]/span[3]")
        arr(8) = GettheNode(bfstr & "li[" & i & "]/div[2]/div[2]/span[2]")
        arr(9) = GettheNode(bfstr & "li[" & i & "]/div[2]/div[4]")
        arr(10) = GettheNode(bfstr & "li[" & i & "]/div[3]/span[1]")
        arr(11) = GettheNode(bfstr & "li[" & i & "]/div[3]/span[2]")
        arr(12) = GettheNode(bfstr & "li[" & i & "]/div[2]/div[2]/span[5]")
        arr(13) = GettheNode(bfstr & "li[" & i & "]/div[2]/div[1]/a[1]")
        lastR = Cells(1048576, 1).End(xlUp).Row + 1
        Range("A" & lastR & ":N" & lastR).Value = arr
    Next i
    lastR = Cells(1048576, 1).End(xlUp).Row + 1
    Range("A" & lastR).Select
    DoEvents
End Sub

Function GettheNode(xPath As String)
    If s.isnodein(doc, xPath) Then
        GettheNode = s.getnode(doc, xPath)
    End If
End Function

Function tryM1()
    On Error GoTo line
    tryM1 = Split(tparr(0), ";")(2)
    Exit Function
line:
    tryM1 = ""
End Function

Function tryM3()
    On Error GoTo line
    tryM3 = tparr(2)
    Exit Function
line:
    tryM3 = ""
End Function

Function DefineDic()
    Set d = s.newdic
    d.Add "pudong", "浦东": d.Add "minhang", "闵行": d.Add "baoshan", "宝山": d.Add "xuhui", "徐汇": d.Add "songjiang", "松江": d.Add "jiading", "嘉定"
    d.Add "jingan", "静安": d.Add "putuo", "普陀": d.Add "yangpu", "杨浦": d.Add "hongkou", "虹口": d.Add "changning", "长宁": d.Add "huangpu", "黄浦"
    d.Add "qingpu", "青浦": d.Add "fengxian", "奉贤": d.Add "jinshan", "金山": d.Add "chongming", "崇明": d.Add "shanghaizhoubian", "上海周边"
End Function


这段代码可以爬取安居客上海的所有房源信息。
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 03:44 , Processed in 0.035784 second(s), 9 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表