网抓技巧-剪贴板快速复制网页表格,适用于保留整表及保留网页表格原格式

百度不到去谷歌

在网抓的时候 大部分情况都是抓取表格数据到页面 如果表格规整 循环遍历页代码还好写如果遇到有合并单元格 或者需要保留表格原格式 写代码就显得很麻烦
有一次正好是客户要求保留原格式 我开始也是遍历读取
写到一半突然想起来我们平时不是经常从网页复制粘贴表格到excle么
于是我就尝试代码复制htmldocument对象的表格到excel里粘贴 没想到还真可以
进而再一步实验 只要获取了源码 复制源码中table标签内的字表格字符串
那么粘贴后即可完整保持原来表格格式个样式
测试表及代码如下
测试网页http://www.taifex.com.tw/chinese/3/7_8.asp
需要获得表格截图如下

可以看到这个表格有很多合并单元格排版 还有颜色
采用剪贴板复制法  我们可以很方便的将整表放入
导出结果如下如 格式完美复制 不用遍历 操作简单方便

代码如下 网页表格快速导出.rar (63.19 KB, 下载次数: 495)

2015-3-17 14:52 上传

点击文件名下载附件

1. Option Explicit
   
2. Public Sub tableTest()
   
3.     Dim txt, web
   
4.     Set web = CreateObject("MSXML2.XMLHTTP")
   
5.     web.Open "Get", "http://www.taifex.com.tw/chinese/3/7_8.asp", False
   
6.     web.send
   
7.     txt = web.responsetext
   
8.     txt = "<table>" & HtmlFilter(txt, "table_f"">", "</table>")
   
9.     PutClipboard txt
   
10.     Cells.Clear
    
11.     [A1].Select
    
12.     ActiveSheet.Paste
    
13. End Sub
    
14. Public Function HtmlFilter(ByVal htmlText$, Label1$, label2$)
    
15. '返回html字符串lable1和最近的lable2标签中的数据
    
16.     Dim pStart As Long, pStop As Long
    
17.     '开始位置，结束位置
    
18.     pStart = InStr(htmlText, Label1) + Len(Label1)
    
19.     '找到标签信息的起始位置
    
20.     If pStart <> 0 Then
    
21.         pStop = InStr(pStart, htmlText, label2)
    
22.         HtmlFilter = Mid(htmlText, pStart, pStop - pStart)
    
23.     End If
    
24. End Function
    
25. Public Sub PutClipboard(ByVal tt$) 'tt放入剪贴板
    
26.     With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")       '调试用，数据放入剪贴板
    
27.         .SetText tt
    
28.         .PutInClipboard
    
29.     End With
    
30. End Sub
    

复制代码

该贴已经同步到 百度不到去谷歌的微博

feiren228

学习，收藏。

VBA万岁

如需转码怎么办？
如附件：
NBA赛事直播.zip (835.74 KB, 下载次数: 38)

2015-3-18 14:19 上传

点击文件名下载附件

VBA万岁

应用（一）复制文本、格式及链接：

1. Option Explicit
   
2. Public Sub tableTest()
   
3.     Dim txt, web
   
4.     Set web = CreateObject("MSXML2.XMLHTTP")
   
5.     web.Open "Get", "http://nba.sports.sina.com.cn/match_result.php?dpc=1", False
   
6.     web.send
   
7.     txt = StrConv(web.responseBody, vbUnicode, &H804)
   
8.     txt = "<table>" & HtmlFilter(txt, "table980middle"">", "table980bottom")
   
9.     PutClipboard txt
   
10.     Cells.Clear
    
11.     [A1].Select
    
12.     ActiveSheet.Paste
    
13.    
    
14.     txt = StrConv(web.responseBody, vbUnicode, &H804)
    
15.     txt = HtmlFilter(txt, "<strong>", "</div>")
    
16.     PutClipboard txt
    
17.     Range("A" & ActiveSheet.UsedRange.Rows.Count + 2).Select
    
18.     ActiveSheet.Paste
    
19. End Sub
    
20. 
    
21. Public Sub tableTest2()
    
22.     Dim txt, web
    
23.     Set web = CreateObject("MSXML2.XMLHTTP")
    
24.     web.Open "Get", "http://nba.sports.sina.com.cn/league_order1.php?dpc=1", False
    
25.     web.send
    
26.     txt = StrConv(web.responseBody, vbUnicode, &H804)
    
27.     txt = "<table>" & HtmlFilter(txt, "table980middle"">", "</table>")
    
28.     PutClipboard txt
    
29.     Cells.Clear
    
30.     [A1].Select
    
31.     ActiveSheet.Paste
    
32.    
    
33.     txt = StrConv(web.responseBody, vbUnicode, &H804)
    
34.     txt = HtmlFilter(txt, "<strong>", "</div>")
    
35.     PutClipboard txt
    
36.     [A39].Select
    
37.     ActiveSheet.Paste
    
38. End Sub
    
39. 
    
40. Public Function HtmlFilter(ByVal htmlText$, Label1$, label2$)
    
41. '返回html字符串lable1和最近的lable2标签中的数据
    
42.     Dim pStart As Long, pStop As Long
    
43.     '开始位置，结束位置
    
44.     pStart = InStr(htmlText, Label1) + Len(Label1)
    
45.     '找到标签信息的起始位置
    
46.     If pStart <> 0 Then
    
47.         pStop = InStr(pStart, htmlText, label2)
    
48.         HtmlFilter = Mid(htmlText, pStart, pStop - pStart)
    
49.     End If
    
50. End Function
    
51. 
    
52. Public Sub PutClipboard(ByVal tt$) 'tt放入剪贴板
    
53.     With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")       '调试用，数据放入剪贴板
    
54.         .SetText tt
    
55.         .PutInClipboard
    
56.     End With
    
57. End Sub
    

复制代码

VBA万岁

VBA万岁 发表于 2015-3-18 14:20
如需转码怎么办？
如附件：

多谢！按指点已解决！
应用（一）复制文本、格式与链接：
NBA赛事直播.zip (845.62 KB, 下载次数: 156)

2015-3-19 17:30 上传

点击文件名下载附件

liucqa

最后这个函数好熟悉，呵呵

liucqa

支持一下，现在肯钻研的人不多了            

浮华、缠绕指尖

还用什么HtmlFilter，直接取table，然后使用innerhtml属性就好了，几乎就和QT配型了。

mjzxlmg

很好，有参考价值，支持。

VBA万岁

VBA万岁 发表于 2015-3-19 17:34
多谢！按指点已解决！
应用（一）复制文本、格式与链接：

应用（二）复制文本与图片（附件虽老旧了点，但还是能体现剪贴板的强大功能）：
伦敦奥运会奖牌榜_2012.zip (822.01 KB, 下载次数: 139)

2015-3-20 10:19 上传

点击文件名下载附件