楼主
kevinchengcw |
Q: 如何用vba代码通过正则表达式提取网页中指定的表格？
A: 实现代码如下：- Sub test()
- Dim Rule, N&, I&, T&, MaxP&, RegEx As Object, Str$, Arr, Rng As Range
- Rule = Array(67, 68) '设置基金类型表
- Set RegEx = CreateObject("vbscript.regexp") '创建正则表达式
- With RegEx
- .Global = True '全局有效
- .MultiLine = True '多行有效
- .ignorecase = True '忽略大小写(网页处理时这个参数比较重要)
- End With
- Cells.Clear '清空结果表内容
- With CreateObject("msxml2.xmlhttp") '创建xmlhttp用于读取网页源代码
- For N = LBound(Rule) To UBound(Rule) '循环结果基金类型数组
- I = 1 '初始化页码
- MaxP = 0 '初始化最大页码值
- Do '执行循环操作
- .Open "get", "http://quote.stockstar.com/stock/external_fund.aspx?pageid=" & I & "&retype=" & Rule(N), False '获取对应页源代码
- .send '发送请求
- Str = .responsetext '提取返回的网页源代码
- With RegEx
- .Pattern = "pageid\=(\d+)[^<>]*?\>最后一页\<" '设置匹配提取最后一页页码数的规则
- If .test(Str) Then '如果可以匹配到结果,则
- T = Val(.Execute(Str)(0).submatches(0)) '通过匹配结果中对应的分组提取对应页码
- If MaxP < T Then MaxP = T '如果最后一页页码大于当前最后一页页码,则取最大值
- End If
- .Pattern = "(\<table[\s\S]*?序号[\s\S]*?换手率\<[\s\S]*?<\/tr\>)([\s\S]*?\<\/table\>)" '设置匹配表格的规则(注:匹配内容进行分组处理,分组1为标题内容,分组2为数据内容)
- If .test(Str) Then '如果匹配到数据,则
- If [a1] = "" Then Str = .Execute(Str)(0).Value Else Str = .Execute(Str)(0).submatches(1) '当A1为空时提取内容含标题行,否则不含标题行
- .Pattern = "^\s+|(\>)\s+(\<)|\s+$" '设置规则去除无效的空白字符
- Str = Replace(Replace(.Replace(Str, "$1$2"), "</tr>", vbCrLf, , , vbTextCompare), "</td>", vbTab, , , vbTextCompare) '去除空白字符后,将"</tr>"替换为回车换行符,将"</td>"替换为制表符(利用vbTextCompare参数忽略大小写)
- .Pattern = "\<[^<>]*?\>" '设置匹配网页控制符内容串
- Str = .Replace(Str, "") '替换为空
- Arr = Split(Str, vbCrLf) '将结果依回车换行符拆分放入数组
- If [a1] = "" Then Set Rng = [a1] Else Set Rng = Cells(Rows.Count, 1).End(3).Offset(1) '确定数据写入的起始位置
- With Rng.Resize(UBound(Arr) + 1) '将结果写入并拆分数据到各列中
- .Value = Application.Transpose(Arr)
- .TextToColumns Tab:=True
- End With
- End If
- End With
- I = I + 1 '页码加1
- Loop While I <= MaxP '如果页码不大于最后页则继续循环
- Next N
- End With
- Set RegEx = Nothing '清空正则项目
- End Sub
详见附件及素材源帖。
 GetData.rar
|
