只要抓取网页中加号伸缩部分的表格数据

guanlearn

请教坛中大师们，网页中有加号需要展开，只要取网页中部分表格内容，能在剪贴板里就取好再paste到sheet中吗？全部网页处理好像速度较慢！同样问题有位大师是把这个网页数据从剪贴板paste到sheet的，还是要先感谢这位大师，这位大师还指出是第15个</tbody>。不知道有无方法直接就抓取这部分数据？谢谢！并祝坛中大师们粽子节快乐！！

lsdongjh

1. <!--<span.*?>(.*?)</span></td>-->(.*\n)*?.*?受影响主机</th>\n.*?<td.*?>(.*)\n(.*\n)*?.*?详细描述</th>\n.*?<td>((.*\n)*?.*?)</td>\n(.*\n)*?.*?解决办法</th>\n.*?<td>((.*\n)*?.*?)</td>

复制代码

共856，每个Match中的都有9个Group,其中 1、3、5、8 四个Group就是你要的数据

guanlearn

lsdongjh 发表于 2018-6-21 16:03
共856，每个Match中的都有9个Group,其中 1、3、5、8 四个Group就是你要的数据

Is侠：按您的正则测试了很正确！但能冒昧请求您写个完整的vba吗？4个Group还是不会弄到表格里去！先谢谢了！我是一个很菜的菜鸟，还望得到Is侠的指点！

lsdongjh

1. Sub Test()
   
2.     Dim strPath As String
   
3.     Dim ObjStream As Object, objReg As Object, strPat As String
   
4.     Dim objMatchs As Object, objMatch As Object
   
5.     Dim strTemp As String, arrResult As Variant
   
6.     Dim lngRows As Long, lngIndex As Long
   
7.    
   
8.     strPath = ThisWorkbook.Path & "\index.html"
   
9.    
   
10.     Set ObjStream = CreateObject("Adodb.Stream")
    
11.     With ObjStream
    
12.         .Mode = 3
    
13.         .Type = 1
    
14.         .Open
    
15.         .LoadFromFile strPath
    
16.         .Position = 0
    
17.         .Type = 2
    
18.         .Charset = "UTF-8"
    
19.         strTemp = .readtext
    
20.     End With
    
21.    
    
22.     Set ObjStream = Nothing
    
23.    
    
24.     strPat = "<!--<span.*?>(.*?)</span></td>-->(.*\n)*?.*?受影响主机</th>\n.*?<td.*?>(.*)\n(.*\n)*?.*?详细描述</th>\n.*?<td>((.*\n)*?.*?)</td>\n(.*\n)*?.*?解决办法</th>\n.*?<td>((.*\n)*?.*?)</td>"
    
25. 
    
26.     Set objReg = CreateObject("VBScript.RegExp")
    
27.     With objReg
    
28.         .Global = True
    
29.         .Pattern = strPat
    
30.     End With
    
31. 
    
32.     Set objMatchs = objReg.Execute(strTemp)
    
33.     lngRows = objMatchs.Count + 1
    
34.     ReDim arrResult(1 To lngRows, 1 To 5)
    
35.     arrResult(1, 1) = "序号"
    
36.     arrResult(1, 2) = "漏洞名称"
    
37.     arrResult(1, 3) = "受影响主机"
    
38.     arrResult(1, 4) = "详细描述"
    
39.     arrResult(1, 5) = "解决办法"
    
40.     lngIndex = 2
    
41.    
    
42.     For Each objMatch In objMatchs
    
43.       arrResult(lngIndex, 1) = lngIndex - 1
    
44.       arrResult(lngIndex, 2) = objMatch.subMatches(0)
    
45.       arrResult(lngIndex, 3) = objMatch.subMatches(2)
    
46.       arrResult(lngIndex, 4) = objMatch.subMatches(4)
    
47.       arrResult(lngIndex, 5) = objMatch.subMatches(7)
    
48. 
    
49.       lngIndex = lngIndex + 1
    
50.     Next
    
51. 
    
52.     Sheet1.Range("A1").Resize(lngRows, 5) = arrResult
    
53. End Sub

复制代码

guanlearn

lsdongjh 发表于 2018-6-25 14:00

感谢，非常感谢！快了不止5倍！！！

guanlearn

guanlearn 发表于 2018-6-25 15:19
感谢，非常感谢！快了不止5倍！！！

Is侠：不好意思，又来打扰您了！首先非常感谢！but在遍历submatches时，发现4和5、7和8有部分是重复的。怎么回事呢？能帮忙分析分析吗？再次表示感谢！！