网页数据提取，请高手帮一下忙，谢谢！

烟火孤星泪

有大神在吗

Kaohsing

愿意要多少期？10000期够吗？

fkeih_007

烟火孤星泪 发表于 2018-10-13 19:35
有大神在吗

初学网抓，望大神指正

1. Sub Main2()
   
2.     Dim strText As String, Regx As Object, arr, brr(1 To 400, 1 To 6)
   
3.     Range("A3:F402").Clear
   
4.     With CreateObject("WinHttp.WinHttpRequest.5.1")
   
5.         .Open "GET", "https://www.qqff6.com/History/LoadHistory?count=400&showType=0&r=1539490562415", False
   
6.         .Send
   
7.         strText = .responsetext
   
8.     End With
   
9.         arr = Split(strText, "font_gray"">")
   
10.         For i = 1 To 400
    
11.           brr(i, 1) = Replace(Split(arr(i), "</span></td>")(0), "</i>", "")
    
12.           For j = 2 To 6
    
13.             brr(i, j) = Split(Split(arr(i), "</i>")(j - 1), "<i>")(1)
    
14.           Next
    
15.         Next
    
16.     Range("A3:F402") = brr
    
17. End Sub
    
18. 
    

复制代码

Kaohsing

部分数据：
ffc.zip (142.25 KB, 下载次数: 6)

2018-10-14 07:40 上传

点击文件名下载附件

zmj9151

fkeih_007 发表于 2018-10-13 21:56
初学网抓，望大神指正

请问101－400的链接是用什么软件得到的，谢谢

Kaohsing

fiddle抓包

fkeih_007

通过抓包分析，可以一次性取出最新400期

1. Sub Main()
   
2.     Dim strText As String, Regx As Object, arr, brr(1 To 6)
   
3.     Range("A3:F402").Clear
   
4.     With CreateObject("WinHttp.WinHttpRequest.5.1")
   
5.         .Open "GET", "https://www.qqff6.com/History/LoadHistory?count=400&showType=0&r=1539490562415", False
   
6.         .Send
   
7.         strText = .responsetext
   
8.         Set Regx = CreateObject("vbscript.regexp")
   
9.           Regx.Global = True
   
10.           Regx.Pattern = "<td>\d\d:\d\d</td>"
    
11.           strText = Regx.Replace(strText, "#")
    
12.         arr = Split(strText, "#")
    
13.         For i = 1 To 400
    
14.           brr(1) = Replace(Split(Split(arr(i), "font_gray"">")(1), "</span>")(0), "</i>", "")
    
15.           Regx.Pattern = "<i>(\d)</i>"
    
16.           n = 1
    
17.           For Each mh In Regx.Execute(arr(i))
    
18.             n = n + 1
    
19.             brr(n) = mh.submatches(0)
    
20.           Next
    
21.           Cells(i + 2, 1).Resize(1, 6) = brr
    
22.         Next
    
23.     End With
    
24. End Sub

复制代码