[已解决]EXCEL提取信息，总是不能提取前2行

demon558

部分代码

strFind = "<table class=""cpzs_table mt10"">"

    strText = Split(strText, strFind)(1)

    strText = Split(strText, "</table>")(0)

    arr1 = Split(strText, "</tr>")

    m = m + 1

    ReDim result(1 To UBound(arr1), 1 To 6)

    '标题

    result(m, 1) = "期数"

    result(m, 2) = "开奖号码"

    For j = 4 To UBound(arr1)

        If arr1(j) Like "<tr><td>*" Then

            arr2 = Split(arr1(j), "</td>")

            m = m + 1

            '第1列期数

            result(m, 1) = Split(Split(arr1(j), "</td")(0), "<td>")(1)

            '第2列到6列

            For k = LBound(arr2) + 1 To UBound(result, 2) - 1

                result(m, k + 1) = Split(Split(arr2(k), "<span class=""spNum"">")(1), "<")(0)

            Next

        Else

            Exit For

        End If

    Next

66666666666.rar (6.36 KB, 下载次数: 11)

2013-6-9 17:07 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-6-10 07:43

字符串方法略快0.02秒。
关键是简单易懂。

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

复制代码

跳转到最佳答案楼层

hwc2ycy

第一行的数据读取出来有点问题。

hwc2ycy

鼠标没电了，明天再来做。

hwc2ycy

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

复制代码

处理第3行的文本，用字符串的方法也可以。

hwc2ycy

字符串方法略快0.02秒。
关键是简单易懂。

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

复制代码

demon558

hwc2ycy 发表于 2013-6-10 07:43
字符串方法略快0.02秒。
关键是简单易懂。

可不可以不要标题？第一行直接是号码的


变成

hwc2ycy

1. Sub 查询福彩前4页2()
   
2. 
   
3.     Dim strDate$
   
4.     Dim strUrl$
   
5.     Dim strText$
   
6.     Dim strFind$
   
7.     Dim strTemp$
   
8.     Dim ARR1, arr2, result(1 To 600, 1 To 6)
   
9.     Dim J As Byte, k As Byte, M As Integer
   
10.     Dim httpRequest As Object
    
11.     Dim btPage As Byte
    
12. 
    
13.     For btPage = 1 To 5
    
14.         strUrl = "http://fjtc.com.cn/Line-1105?Page=" & btPage
    
15.         Set httpRequest = CreateObject("Msxml2.XMLHTTP.3.0")
    
16.         With httpRequest
    
17.             .Open "GET", strUrl, False
    
18.             .send
    
19.             strText = .responseText
    
20.         End With
    
21. 
    
22.         strFind = "<table class=""cpzs_table mt10"">"
    
23.         strText = Split(strText, strFind)(1)
    
24.         strText = Split(strText, "</table>")(0)
    
25.         ARR1 = Split(strText, "</tr>")
    
26. 
    
27.         For J = 3 To UBound(ARR1)
    
28.             strTemp = ARR1(J)
    
29.             If strTemp Like "*<tr><td>*" Then
    
30.                 strTemp = Mid(strTemp, InStr(strTemp, "<tr><td>"))
    
31.             Else
    
32.                 Exit For
    
33.             End If
    
34. 
    
35.             arr2 = Split(strTemp, "</td>")
    
36. 
    
37.             M = M + 1
    
38.             '第1列期数
    
39.             result(M, 1) = Split(Split(strTemp, "</td")(0), "<td>")(1)
    
40.             '第2列到6列
    
41.             For k = LBound(arr2) + 1 To UBound(result, 2) - 1
    
42.                 result(M, k + 1) = Split(Split(arr2(k), "<span class=""spNum"">")(1), "<")(0)
    
43.             Next
    
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.    
    
55.     Application.ScreenUpdating = True
    
56.     MsgBox "提取完成"
    
57. End Sub
    

复制代码

demon558

hwc2ycy 发表于 2013-6-10 11:27

thank you
and 另一个问题
求同时不出数组的间隔次数

如计算一行中同时不出现1，2，3，就是最后一行符合条件
sheet2.rar (217.69 KB, 下载次数: 3)

2013-6-10 13:19 上传

点击文件名下载附件

在sheet2中，有的计算是正确的，有的不正确。