刚学网抓，试着抓了下EH论坛的帖子。

kldxlb

看了吴姐的网抓教程，试着抓了一下EH论坛VBA版块的帖子，这应该是最简单的网抓实例了，不需要cookie和referer的模拟，更不需要js分析。小白可以参考一下练练手。大神看到了看看能不能指点优化一下，因为速度还是有点慢，一分钟大概才抓70个网页。代码如下

1. Function strText(ByVal url As String) As String
   
2. On Error GoTo UNDEFIND '若异常则返回“访问异常”
   
3. DoEvents
   
4. With CreateObject("MSXML2.XMLHTTP")
   
5.     .Open "GET", url, False
   
6.     .Send
   
7.     strText = Right(ByteToStr(.responsebody, "gbk"), Len(ByteToStr(.responsebody, "gbk")) - InStr(ByteToStr(.responsebody, "gbk"), "</a>]</em> <a href=""") - Len("</a>]</em> <a href=""") + 1)
   
8.     'Debug.Print ByteToStr(.responsebody, "gbk")
   
9.     GoTo FUNRETURN '若正正常则返回数据
   
10. End With
    
11. UNDEFIND: strText = "访问异常"
    
12. FUNRETURN:
    
13. End Function
    
14. Public Sub URL_REPLY()
    
15.     t = Timer
    
16.     Dim r As Long
    
17.     Dim sh As Worksheet
    
18.     Set sh = ActiveSheet
    
19.     Dim eachurl
    
20.     Dim maxrow
    
21.     response = strText("http://club.excelhome.net/forum-2-1.html")
    
22.     If response = "访问异常" Then
    
23.         MsgBox "访问异常"
    
24.         Exit Sub
    
25.     End If
    
26.     On Error Resume Next
    
27.     pgcount = Split(Split(response, "class=""last"">... ")(1), "</a>")(0)
    
28.     For pg = 1 To Val(pgcount)
    
29.     'For pg = 1 To 100
    
30.         response = strText("http://club.excelhome.net/forum-2-" & pg & ".html")
    
31.         'Debug.Print response
    
32.         If response = "访问异常" Then
    
33.             MsgBox "访问异常"
    
34.             Exit For
    
35.         End If
    
36.         eachurl = Split(response, "</a>]</em> <a href=""")
    
37.         maxrow = sh.UsedRange.Rows.Count
    
38.         For i = maxrow + 1 To maxrow + UBound(eachurl) + 1
    
39.             sh.Range("A" & i).Value = "http://club.excelhome.net/" & Split(eachurl(i - maxrow - 1), """")(0)
    
40.             sh.Range("B" & i).Value = Split(Split(eachurl(i - maxrow - 1), "class=""s xst"">")(1), "</a>")(0)
    
41.         Next
    
42.         For r = sh.Range("C1048576").End(3).Row + 1 To sh.UsedRange.Rows.Count
    
43.             If sh.Range("A" & r).Value <> "" Then
    
44.                 result = strText(sh.Range("A" & r).Value)
    
45.                 If result = "访问异常" Then
    
46.                     sh.Range("C" & r).Value = result
    
47.                     sh.Range("D" & r).Value = result
    
48.                 Else
    
49.                     On Error Resume Next
    
50.                     ck = Split(Split(result, "<span class=""xg1"">查看:</span> <span class=""xi1"">")(1), "</span>")(0)
    
51.                     hf = Split(Split(result, "<span class=""xg1"">回复:</span> <span class=""xi1"">")(1), "</span>")(0)
    
52.                     sh.Range("C" & r).Value = ck
    
53.                     sh.Range("D" & r).Value = hf
    
54.                 End If
    
55.             End If
    
56.         Next
    
57.     Next
    
58.     MsgBox "完成，用时" & Timer - t & "秒"
    
59. End Sub
    
60. Function ByteToStr(arrByte, strCharset As String) As String
    
61.     With CreateObject("Adodb.Stream")
    
62.         .Type = 1 'adTypeBinary
    
63.         .Open
    
64.         .Write arrByte
    
65.         .Position = 0
    
66.         .Type = 2 'adTypeText
    
67.         .Charset = strCharset
    
68.         ByteToStr = .Readtext
    
69.         .Close
    
70.     End With
    
71. End Function

复制代码

Kaohsing

共有2500页，每页有50条，数据这麽多这还不慢。     strText = ByteToStr(.responsebody, "gbk")
    strText = Right(strText, Len(strText) - InStr(strText, "</a>]</em> <a href=""") - Len("</a>]</em> <a href=""") + 1)

少执行执行ByteToStr（）三遍，多少省点时间。

kldxlb

Kaohsing 发表于 2017-1-20 10:36
共有2500页，每页有50条，数据这麽多这还不慢。

有什么改进的办法吗？预计爬完这2500*50条需要27小时。。。

Kaohsing

kldxlb 发表于 2017-1-20 10:41
有什么改进的办法吗？预计爬完这2500*50条需要27小时。。。

我运行前50页，恢复与查看只有前49条有。网址与表题 以及恢复与查看等项目你是两步走</em> <a href="thread-1325003-1-1.html" class="s xst">刚学网抓，试着抓了下EH论坛的帖子。</a>
<img src="static/image/stamp/011.small.gif" alt="新人帖" align="absmiddle" />
<a href="forum.php?mod=redirect&tid=1325003&goto=lastpost#lastpost" class="xi1">New</a>
</th><td class="by"><cite>
<a href="home.php?mod=space&uid=3631535" c="1">kldxlb</a></cite>
<em><span class="xi1">2017-1-20 09:55</span></em>
</td>
<td class="num"><a href="thread-1325003-1-1.html" class="xi2">1</a><em>41</em></td>
<td class="by">
<cite><a href="home.php?mod=space&username=Kaohsing" c="1">Kaohsing</a></cite>
<em><a href="forum.php?mod=redirect&tid=1325003&goto=lastpost#lastpost">2017-1-20 10:36</a></em>

可以一起split出来，装入数组，最后一次写入单元格，可能还能节省点时间。

kldxlb

Kaohsing 发表于 2017-1-20 11:03
我运行前50页，恢复与查看只有前49条有。网址与表题 以及恢复与查看等项目你是两步走 刚学网抓，试着抓了 ...

我想复杂了，原来查看与回复在主页面就可以找到，我还挨个打开查找。。多谢大神指点，下午我改改再发上来

Kaohsing

kldxlb 发表于 2017-1-20 12:22
我想复杂了，原来查看与回复在主页面就可以找到，我还挨个打开查找。。多谢大神指点，下午我改改再发上来

我说咋反复执行那两个自定义函数，看的眼花缭乱，就没有仔细看下去啦，可能这里浪费了时间。

kldxlb

经过kaohsing老师的指点，修改了代码，进度明显加快了。经测试，抓50页2000条仅用77秒

1. Function strText(ByVal url As String) As String
   
2. On Error GoTo UNDEFIND '若异常则返回“访问异常”
   
3. DoEvents
   
4. With CreateObject("MSXML2.XMLHTTP")
   
5.     .Open "GET", url, False
   
6.     .Send
   
7.     strText = Right(ByteToStr(.responsebody, "gbk"), Len(ByteToStr(.responsebody, "gbk")) - InStr(ByteToStr(.responsebody, "gbk"), "</a>]</em> <a href=""") - Len("</a>]</em> <a href=""") + 1)
   
8.     'Debug.Print ByteToStr(.responsebody, "gbk")
   
9.     GoTo FUNRETURN '若正正常则返回数据
   
10. End With
    
11. UNDEFIND: strText = "访问异常"
    
12. FUNRETURN:
    
13. End Function
    
14. Public Sub URL_REPLY()
    
15.     t = Timer
    
16.     Dim r As Long
    
17.     Dim sh As Worksheet
    
18.     Set sh = ActiveSheet
    
19.     Dim eachurl
    
20.     Dim maxrow
    
21.     Dim arr
    
22.     response = strText("http://club.excelhome.net/forum-2-1.html")
    
23.     If response = "访问异常" Then
    
24.         MsgBox "访问异常"
    
25.         Exit Sub
    
26.     End If
    
27.     On Error Resume Next
    
28.     ReDim arr(1 To 4, 1 To 1)
    
29.     For pg = 1 To 50
    
30.     'For pg = 1 To 2500
    
31.         response = strText("http://club.excelhome.net/forum-2-" & pg & ".html")
    
32.         'Debug.Print response
    
33.         If response = "访问异常" Then
    
34.             MsgBox "访问异常"
    
35.             Exit For
    
36.         End If
    
37.         eachurl = Split(response, "</a>]</em> <a href=""")
    
38.         j = 0
    
39.         For i = 1 + UBound(arr, 2) To UBound(eachurl) + UBound(arr, 2)
    
40.             ReDim Preserve arr(1 To 4, 1 To i)
    
41.             arr(1, i) = "http://club.excelhome.net/" & Split(eachurl(j), """")(0)
    
42.             arr(2, i) = Split(Split(eachurl(j), "class=""s xst"">")(1), "</a>")(0)
    
43.             arr(3, i) = Split(Split(eachurl(j), "</a><em>")(1), "</em>")(0)
    
44.             arr(4, i) = Split(Split(eachurl(j), "html"" class=""xi2"">")(1), "</a><em>")(0)
    
45.             j = j + 1
    
46.         Next
    
47.         Application.StatusBar = "正在抓取第" & pg & "页内容"
    
48.     Next
    
49.     arr(1, 1) = "URL"
    
50.     arr(2, 1) = "标题"
    
51.     arr(3, 1) = "查看"
    
52.     arr(4, 1) = "回复"
    
53.     Range("A1").Resize(UBound(arr, 2), 4) = Application.Transpose(arr)
    
54.     MsgBox "完成，用时" & Timer - t & "秒"
    
55. End Sub
    
56. Function ByteToStr(arrByte, strCharset As String) As String
    
57.     With CreateObject("Adodb.Stream")
    
58.         .Type = 1 'adTypeBinary
    
59.         .Open
    
60.         .Write arrByte
    
61.         .Position = 0
    
62.         .Type = 2 'adTypeText
    
63.         .Charset = strCharset
    
64.         ByteToStr = .Readtext
    
65.         .Close
    
66.     End With
    
67. End Function

复制代码

13907933959

kldxlb 发表于 2017-1-20 14:47
经过kaohsing老师的指点，修改了代码，进度明显加快了。经测试，抓50页2000条仅用77秒

前辈好！
我怎么不能运行，提示：编译错误：用户定义类型未定义。

另外、请问一下前辈，有不有办法网抓EH论坛VBA版块指定的帖子，例如：

提取的网址：http://club.excelhome.net/forum. ... digest%26digest%3D1

只提取帖子（包括翻页）每个回复的内容，但不包括回复框内所有的广告、点评、评分…等。

提取代码通过更改网址，也可抓取本论坛上其它帖子的内容。

求前辈赐教！谢谢！

kldxlb

13907933959 发表于 2017-1-20 16:29
前辈好！
我怎么不能运行，提示：编译错误：用户类型未定义。

应该是可以的，我写写试试

13907933959

kldxlb 发表于 2017-1-20 16:35
应该是可以的，我写写试试

感谢前辈帮忙！