[已解决]请教用EXCEL解析网站的可能性

demon558

fjtc.com.cn/Line-1105
上面是网址，要提取其中红圈里的信息如图。可行吗

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-5-22 06:57

1. Sub 查询福彩前4页()
   
2. 
   
3.     Dim strDate$
   
4.     Dim strUrl$
   
5.     Dim strText$
   
6.     Dim strFind$
   
7.     Dim arr1, arr2, result(1 To 400, 1 To 6)
   
8.     Dim i As Long, j As Byte, k As Byte, m As Integer
   
9.     Dim httpRequest As Object
   
10.     Dim btPage As Byte
    
11.     m = 1
    
12.     '标题
    
13.     result(m, 1) = "期数"
    
14.     result(m, 2) = "开奖号码"
    
15. 
    
16.     For btPage = 1 To 4
    
17. 
    
18.         strUrl = "http://fjtc.com.cn/Line-1105?Page=" & btPage
    
19.         Set httpRequest = CreateObject("Msxml2.XMLHTTP.3.0")
    
20.         With httpRequest
    
21.             .Open "GET", strUrl, False
    
22.             .send
    
23.             strText = .responseText
    
24.         End With
    
25. 
    
26.         strFind = "<table class=""cpzs_table mt10"">"
    
27.         strText = Split(strText, strFind)(1)
    
28.         strText = Split(strText, "</table>")(0)
    
29.         arr1 = Split(strText, "</tr>")
    
30. 
    
31.         For j = 4 To UBound(arr1)
    
32.             If arr1(j) Like "<tr><td>*" Then
    
33.                 arr2 = Split(arr1(j), "</td>")
    
34.                 m = m + 1
    
35.                 '第1列期数
    
36.                 result(m, 1) = Split(Split(arr1(j), "</td")(0), "<td>")(1)
    
37.                 '第2列到6列
    
38.                 For k = LBound(arr2) + 1 To UBound(result, 2) - 1
    
39.                     result(m, k + 1) = Split(Split(arr2(k), "<span class=""spNum"">")(1), "<")(0)
    
40.                 Next
    
41.             Else
    
42.                 Exit For
    
43.             End If
    
44.         Next
    
45.     Next
    
46. 
    
47.     Application.ScreenUpdating = False
    
48. 
    
49.     With Range("a1")
    
50.         .CurrentRegion.ClearContents
    
51.         .Resize(m, UBound(result, 2)).Value = result
    
52.         .CurrentRegion.EntireColumn.AutoFit
    
53.     End With
    
54.     Range("B1:F1").HorizontalAlignment = xlCenterAcrossSelection
    
55. 
    
56.     Application.ScreenUpdating = True
    
57.     MsgBox "提取完成"
    
58. End Sub
    

复制代码

跳转到最佳答案楼层

hwc2ycy

这是提取彩票信息吧？

hwc2ycy

你最好把网址贴出来。不然大罗神仙也没法帮你解决的。

demon558

对的，开奖号的前三位

demon558

hwc2ycy 发表于 2013-5-19 20:59
你最好把网址贴出来。不然大罗神仙也没法帮你解决的。

网址有给啊，完整的网址发不出去

www,  fjtc.com.cn/Line-1105

hwc2ycy

哪个彩，这个应该很容易的。

demon558

福建体彩 11选5 前三

hwc2ycy

查这个么？


只要开奖号码和基数吧？

hwc2ycy

1. Sub 查询福彩()
   
2. 
   
3.     Dim strDate$
   
4.     Dim strUrl$
   
5.     Dim strText$
   
6.     Dim strFind$
   
7.     Dim arr1, arr2, result()
   
8.     Dim i As Long, j As Byte, k As Byte, m As Byte
   
9.     Dim httpRequest As Object
   
10. 
    
11. 
    
12.     strUrl = "http://www.fjtc.com.cn/Line-1105"
    
13. 
    
14.     Set httpRequest = CreateObject("Msxml2.XMLHTTP.3.0")
    
15.     With httpRequest
    
16.         .Open "GET", strUrl, False
    
17.         .send
    
18.         strText = .responseText
    
19.     End With
    
20.     strFind = "<table class=""cpzs_table mt10"">"
    
21.     strText = Split(strText, strFind)(1)
    
22.     strText = Split(strText, "</table>")(0)
    
23.     arr1 = Split(strText, "</tr>")
    
24.     m = m + 1
    
25.     ReDim result(1 To UBound(arr1), 1 To 6)
    
26. 
    
27. 
    
28.     '标题
    
29.     result(m, 1) = "期数"
    
30.     result(m, 2) = "开奖号码"
    
31. 
    
32.     For j = 4 To UBound(arr1)
    
33.         If arr1(j) Like "<tr><td>*" Then
    
34.             arr2 = Split(arr1(j), "</td>")
    
35.             m = m + 1
    
36. 
    
37.             '第1列期数
    
38.             result(m, 1) = Split(Split(arr1(j), "</td")(0), "<td>")(1)
    
39.             '第2列到6列
    
40.             For k = LBound(arr2) + 1 To UBound(result, 2) - 1
    
41.                 result(m, k + 1) = Split(Split(arr2(k), "<span class=""spNum"">")(1), "<")(0)
    
42.             Next
    
43.         Else
    
44.             Exit For
    
45.         End If
    
46.     Next
    
47. 
    
48.     Application.ScreenUpdating = False
    
49.     With Range("a1")
    
50.         .CurrentRegion.ClearContents
    
51.         .Resize(m, UBound(result, 2)).Value = result
    
52.         .CurrentRegion.EntireColumn.AutoFit
    
53.     End With
    
54.     Application.ScreenUpdating = True
    
55.     MsgBox "提取完成"
    
56. End Sub

复制代码

hwc2ycy

1. Sub 查询福彩只查前3期()
   
2. 
   
3.     Dim strDate$
   
4.     Dim strUrl$
   
5.     Dim strText$
   
6.     Dim strFind$
   
7.     Dim arr1, arr2, result(1 To 4, 1 To 6)
   
8.     Dim i As Long, j As Byte, k As Byte, m As Byte
   
9.     Dim httpRequest As Object
   
10.     Dim myClip As Object
    
11.    
    
12.     strUrl = "http://www.fjtc.com.cn/Line-1105"
    
13. 
    
14.     Set httpRequest = CreateObject("Msxml2.XMLHTTP.3.0")
    
15.     With httpRequest
    
16.         .Open "GET", strUrl, False
    
17.         .send
    
18.         strText = .responseText
    
19.     End With
    
20.     strFind = "<table class=""cpzs_table mt10"">"
    
21.     strText = Split(strText, strFind)(1)
    
22.     strText = Split(strText, "</table>")(0)
    
23.     arr1 = Split(strText, "</tr>")
    
24.     m = m + 1
    
25.     'ReDim result(1 To UBound(arr1), 1 To 6)
    
26. 
    
27.     '标题
    
28.     result(m, 1) = "期数"
    
29.     result(m, 2) = "开奖号码"
    
30. 
    
31.     For j = 4 To 6  'UBound(arr1)
    
32.         'If arr1(j) Like "<tr><td>*" Then
    
33.             arr2 = Split(arr1(j), "</td>")
    
34.             m = m + 1
    
35. 
    
36.             '第1列期数
    
37.             result(m, 1) = Split(Split(arr1(j), "</td")(0), "<td>")(1)
    
38.             '第2列到6列
    
39.             For k = LBound(arr2) + 1 To UBound(result, 2) - 1
    
40.                 result(m, k + 1) = Split(Split(arr2(k), "<span class=""spNum"">")(1), "<")(0)
    
41.             Next
    
42.         'Else
    
43.         '    Exit For
    
44.         'End If
    
45.     Next
    
46. 
    
47.     Application.ScreenUpdating = False
    
48.     With Range("a1")
    
49.         .CurrentRegion.ClearContents
    
50.         .Resize(m, UBound(result, 2)).Value = result
    
51.         .CurrentRegion.EntireColumn.AutoFit
    
52.     End With
    
53.     Application.ScreenUpdating = True
    
54.     MsgBox "提取完成"
    
55. End Sub
    

复制代码