如果你能点进这篇文章，那我们一定是同道中人，我就开门见山直奔主题了。此文将概述VBA爬虫从简单实现到多线程的各种主要思路。需要你有一点VBA和网络前端基础。
本文的代码均在WPS的ET表格下测试通过，Office Excel应该也没有兼容性问题。
内容提要
- VBA爬取网页的方式
- 解决登录问题
- 利用异步加快速度
- 看似不可能的多线程实现
- 总结
1. VBA爬取网页的方式
简单来说，常用的思路有两种：
1.1 使用Webbrowser控件
相当于在Office里打开一个看得见的IE。优点是实现简单，易于调试，整个抓取过程直观可视，易于解决动态网页、跨域登录等棘手问题。缺点是不灵活，有些网页处理不了；还有就是速度慢，很慢，毕竟除了通信之外还需要IE来渲染网页。
方法很简单，在窗体上拖一个Webbrowser控件，名为oIE，访问网页、获取信息的几种方式大致如下：
strURL = "http://foo.com/search.do?keyword=" & strKeyword
oIE.Navigate strURL
Do While oIE.Busy Or (oIE.ReadyState <> 4)
DoEvents
Loop
'整个HTML response:
Thisworkbook.Sheets("Sheet1").Cells(nRow, nColumn) = oIE.Document.documentElement.outerHTML
'从HTML里截一段，用Mid, InStr InStrRev之类:
Thisworkbook.Sheets("Sheet1").Cells(nRow, nColumn) = Mid(oIE.Document.documentElement.outerHTML, InStr(1, oIE.Document.documentElement.outerHTML, "InfoStart"), 5)
'用ID查找元素:
Thisworkbook.Sheets("Sheet1").Cells(nRow, nColumn) = oIE.Document.getElementById("Name").Value
'找到第2个td元素里的内容(编号从0开始):
Thisworkbook.Sheets("Sheet1").Cells(nRow, nColumn) = oIE.Document.getElementsByTagName("td")(2).innerText
注意：Navigate后需要等待Webbrowser控件完成，否则再次Navigate会出错。
1.2 使用XMLhttp对象
优点是速度快，灵活，可以实现GET、POST、Header、Cookie等诸多细节。缺点是比Webbrowser麻烦一点，调试不直观。为了方便引用网页中的信息，不妨把XMLhttp的responsetext装进一个HTMLfile对象，就可以像Webbrowser一样检索了。XMLhttp的用法和Webbrowser类似，最简单的HTTP GET的代码：
Dim oHTTP, oHTML as Object
Set oHTTP = CreateObject("msxml2.xmlhttp.6.0")
Set oHTML = CreateObject("HTMLfile")
strURL = "http://foo.com/search.do?keyword=" & strKeyword
'True是异步模式，访问后需要写个循环等它完成，异步的好处后面说。改成False就是同步模式，Send后不用专门等它
oHTTP.Open "get", strURL, True
oHTTP.Send
Do While oHTTP.ReadyState <> 4
DoEvents
Loop
'用返回的文本建立一个HTML文档便于查找数据
oHTML.body.innerhtml = oHTTP.responsetext
Thisworkbook.Sheets("Sheet1").Cells(nRow, nColumn) = oHTML.getElementById("Name").Value
Set oHTTP = Nothing
Set oHTML = Nothing
2. 解决登录问题
模拟登录的大致代码如下，一看就懂：
oIE.Navigate "http://foo.com/login.do"
Do While oIE.Busy Or (oIE.ReadyState <> 4)
DoEvents
Loop
oIE.Document.getElementById("userName").Value = userName
oIE.Document.getElementById("userPassword").Value = passWord
oIE.Document.getElementById("submitBtn").Click
Do While oIE.Busy Or (oIE.ReadyState <> 4) Or oIE.LocationURL <> "http://foo.com/mainindex.do?method=login&status=1"
DoEvents
Loop
要点如下：
- 用Click模拟登录比把用户名、密码写在url里或者send请求来的简单，通用性也更好。尤其是有些网站的表单submit时要执行额外的script，或者登录时要跨域发送登录信息。
- 如果遇到跨域登录或者iframe的情况，参照上面代码最后一段：Click之后等待真正的登录返回页面，而不是等待登录页加载完毕。
- 如果使用XMLhttp发送登录请求遇到登录问题，建议就不要费力气琢磨什么伪造Cookie了，使用Webbrowser来登录吧，登录后同一个Excel进程里的所有XMLhttp和Webbrowser都会共享到这个登录信息，特别省心。
- 使用Set oIE = CreateObject(“internetexplorer.application”)不能和Webbrowser以及XMLhttp互相共享登录信息，Winhttp似乎也不能。
3. 利用异步加快速度
一个一个等待网页返回太慢，所以我们不用同步方式send一个等待一个，而是用异步，一次send一批请求出去，统一等待。初衷当然很好，然而VBA不支持多线程，所以这里的速度提高比较有限，一次发送20个请求大概只能提速2倍。再多似乎没什么用了。nThread值的选择在很大程度上于所爬网站的速度，建议多次测试决定。
'一共nThread个请求
For i = 1 To nThread
Set oHTTP(i) = CreateObject("msxml2.xmlhttp.6.0")
Set oHTML(i) = CreateObject("HTMLfile")
Next i
For m = 2 To Application.WorksheetFunction.CountA(ThisWorkbook.Sheets("Sheet1").Range("A:A")) - 1 Step nThread
For i = 1 To nThread
URL(i) = "http://foo.com/search.do&keyword=" & ThisWorkbook.Sheets("Sheet1").Cells(m + i - 1, 1).Value
oHTTP(i).Open "get", URL(i), True
oHTTP(i).Send
errflag(i) = False
Next i
'发送后一起等待
For i = 1 To nThread
Do While oHTTP(i).ReadyState <> 4
DoEvents
Loop
Next i
For i = 1 To nThread
oHTML(i).body.innerhtml = oHTTP(i).responsetext
'简单的出错处理
If InStr(1, oHTML(i).body.outerhtml, "Error") <> 0 Then
errflag(i) = True
If target(i) <> "" Then
ThisWorkbook.Sheets("sheet1").Cells(m + i - 1, 2).Value = "Error"
End If
Else
errflag(i) = False
ThisWorkbook.Sheets("sheet1").Cells(m + i - 1, 2).Value = oHTML(i).getElementById("Name").Value
End If
Next i
Next m
4. 看似不可能的多线程实现
也许有很多人跟你说过VBA不支持多线程。没错，它确实不支持，用API极其麻烦而且不稳定。但是，Windows操作系统支持多线程，我们就利用这一点来绕开VBA的限制。不光有办法，而且有三种。
4.1 利用VBScript加Application
将含有宏的工作簿另存n份，生成n个VBScript脚本文件，每个脚本用Excel.Application对象打开一个工作簿，运行每个工作簿里的VBA爬虫，将爬到的结果统一写回主Excel里。这种方式有两个好处：一是用字符串的VBScript代码比较简洁，二是每个线程都可以利用Webbrowser控件方便地登录。缺点就是打开一批Excel导致系统负担较重。
For nWorker = 1 To cmbWorkers.Value 'cmbWorkers复合框保存了总线程数
'保存当前工作簿的拷贝
WorkerFileName = ThisWorkbook.Path & "\~Worker_" & cmbWorkers.Text & "_" & nWorker & ".xlsx"
Call ThisWorkbook.SaveCopyAs(WorkerFileName)
'写VBS脚本。脚本中调用每个工作簿拷贝里面的宏searchWorker，用参数做好线程之间的分工和数据传递
s = "Set objExcel = CreateObject(""Excel.Application"")" & vbCrLf
s = s & "Set objWorkbook = objExcel.Workbooks.Open(""" & WorkerFileName & """)" & vbCrLf
s = s & "objExcel.Application.Visible = False" & vbCrLf
s = s & "objExcel.Application.Run ""~Worker_" & cmbWorkers.Value & "_" & nWorker & ".xlsx!searchWorker"" ," & nWorker & "," & cmbWorkers.Text & ",""" & ThisWorkbook.Name & """," & txtStart.Text & ",""" & txtUserName.Text & """,""" & txtPassword.Text & """" & vbCrLf
s = s & "objExcel.ActiveWorkbook.Close" & vbCrLf
s = s & "objExcel.Application.Quit" & vbCrLf
s = s & "Set objExcel = Nothing" & vbCrLf
'保存VBS脚本文件
scriptFileName = ThisWorkbook.Path & "\~Worker_" & cmbWorkers.Text & "_" & nWorker & ".vbs"
Open scriptFileName For Output As #1
Print #1, s
Close #1
'异步执行VBS脚本
Set wsh = VBA.CreateObject("WScript.Shell")
wsh.Run """" & scriptFileName & """"
Set wsh = Nothing
Next nWorker
searchWorker过程里创建了一个Excel对象，通过工作簿名称workbookName将爬到的数据写回原工作簿。searchWorker代码示例：
Const CThread = 20 '同时发送请求数
Public Sub searchWorker(nWorker As Integer, maxWorkers As Integer, workbookName As String, nRowStart As Long, userName As String, passWord As String)
Application.ScreenUpdating = False
Application.EnableEvents = False
If userName = "" Or passWord = "" Then
MsgBox "Login information required."
Exit Sub
End If
'利用Webbrowser登录
fmUI.oIE.Navigate "http://foo.com/login.do"
Do While fmUI.oIE.Busy Or (fmUI.oIE.ReadyState <> 4)
DoEvents
Loop
fmUI.oIE.Document.getElementById("userName").Value = userName
fmUI.oIE.Document.getElementById("userPassword").Value = passWord
fmUI.oIE.Document.getElementById("submitBtn").Click
Do While fmUI.oIE.Busy Or (fmUI.oIE.ReadyState <> 4) Or fmUI.oIE.LocationURL <> "http://foo.com/mainindex.do?method=login&status=1"
DoEvents
Loop
Dim oXL As Object
Set oXL = GetObject(, "Excel.Application")
Dim target(1 To CThread) As String '查询目标
Dim URL(1 To CThread) As String 'url
Dim errflag(1 To CThread) As Boolean '错误标识
Dim oHTTP(1 To CThread) As Object 'xmlhttp
Dim oHTML(1 To CThread) As Object 'html文档对象
nThread = CThread
n = Application.WorksheetFunction.CountA(ThisWorkbook.Sheets("Sheet1").Range("A:A")) - 1
errmsg = "错误信息"
For i = 1 To nThread
Set oHTTP(i) = CreateObject("msxml2.xmlhttp.6.0")
Set oHTML(i) = CreateObject("htmlfile")
Next i
For m = nRowStart To n Step nThread * maxWorkers
For i = 1 To nThread
target(i) = ThisWorkbook.Sheets("sheet1").Cells(m + (i - 1) * maxWorkers + (nWorker - 1), 1).Value
URL(i) = "http://foo.com/search.do&keyword=" & target(i)
oHTTP(i).Open "get", URL(i), True
oHTTP(i).Send
errflag(i) = False
Next i
For i = 1 To nThread
Do While oHTTP(i).ReadyState <> 4
DoEvents
Loop
Next i
For i = 1 To nThread
oHTML(i).body.innerhtml = oHTTP(i).responsetext
If InStr(1, oHTML(i).body.outerhtml, errmsg) <> 0 Then
errflag(i) = True
msg = "错误"
If target(i) <> "" Then
oXL.Workbooks(workbookName).Sheets("sheet1").Cells(m + (i - 1) * maxWorkers + (nWorker - 1), j).Value = msg
End If
Else
errflag(i) = False
oXL.Workbooks(workbookName).Sheets("sheet1").Cells(m + (i - 1) * maxWorkers + (nWorker - 1), 2).Value = Trim(oHTML(i).getElementsByTagName("td")(5).innertext)
End If
Next i
Next m
Set oXL = Nothing
For i = 1 To nThread
Set oHTTP(i) = Nothing
Set oHTML(i) = Nothing
Next i
End Sub
4.2 只用VBScript实现多线程
有了上一节的示例，很容易就可以构造出合适的VBScript文件，并且在文件里直接抓取数据，代码我就不放了。比起VBScript加Application的方法，只用VBScript拼字符串写起来更麻烦，但程序执行起来非常轻量级，所以如果你要抓取的网站没有复杂的登录过程，又不怕代码麻烦，那么可以考虑用VBScript。示例可以在这里找到，代码相当乱而且长：Multi-threaded VBA
4.3 使用ActiveX EXE实现多线程
这个有前人写过，优点是资源消耗适中，缺点是需要有Visual Basic环境，实现起来也更复杂。参见：VBA异步多线程网抓教程-excelhome
总结
我个人推荐VBScript加Application的多线程方案，通用性更强，而且现在的电脑已经不太在乎多占些内存了。比起本文前面使用XMLhttp批量异步发送的方法，VBS+Application的方案创建8个线程可以提速5倍左右，效率很高。测试电脑是4核心8线程的i7台式机，8G内存。爬虫网抓时，每个WPS ET线程大概占用不到100M内存，机器完全可以承受。
做爬虫可能会遇到很多问题，比如翻页、动态网页、json解析、保存附件等等。有时为了避免被网站封杀，还要加上一些延时。具体问题只能在抓取过程中各个击破。祝各位好运。
以上。
搞定搞不定的老狼
《VBA网页爬虫和多线程指南》上有1条评论