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

Option Explicit

Public Sub tableTest()

Dim txt, web

Set web = CreateObject("MSXML2.XMLHTTP")

web.Open "Get", "http://nba.sports.sina.com.cn/match_result.php?dpc=1", False

web.send

txt = StrConv(web.responseBody, vbUnicode, &H804)

txt = "

PutClipboard txt

Cells.Clear

[A1].Select

ActiveSheet.Paste

txt = StrConv(web.responseBody, vbUnicode, &H804)

txt = HtmlFilter(txt, "", "")

PutClipboard txt

Range("A" & ActiveSheet.UsedRange.Rows.Count + 2).Select

ActiveSheet.Paste

End Sub

Public Sub tableTest2()

Dim txt, web

Set web = CreateObject("MSXML2.XMLHTTP")

web.Open "Get", "http://nba.sports.sina.com.cn/league_order1.php?dpc=1", False

web.send

txt = StrConv(web.responseBody, vbUnicode, &H804)

txt = "

")

PutClipboard txt

Cells.Clear

[A1].Select

ActiveSheet.Paste

txt = StrConv(web.responseBody, vbUnicode, &H804)

txt = HtmlFilter(txt, "", "")

PutClipboard txt

[A39].Select

ActiveSheet.Paste

End Sub

Public Function HtmlFilter(ByVal htmlText$, Label1$, label2$)

'返回html字符串lable1和最近的lable2标签中的数据

Dim pStart As Long, pStop As Long

'开始位置，结束位置

pStart = InStr(htmlText, Label1) + Len(Label1)

'找到标签信息的起始位置

If pStart <> 0 Then

pStop = InStr(pStart, htmlText, label2)

HtmlFilter = Mid(htmlText, pStart, pStop - pStart)

End If

End Function

Public Sub PutClipboard(ByVal tt$) 'tt放入剪贴板

With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")       '调试用，数据放入剪贴板

.SetText tt

.PutInClipboard

End With

End Sub