我想用VBA求获链接搜索得到的数据，谢谢！

我爱你！

我想用VBA求获以下链接搜索得到的联赛、联赛时间、状态、主场球队、比分、客场球队、半场与亚盘八项数据，请高手帮个忙，先谢谢！
http://bf.bet007.com/Over1_cn.htm（按日期获取）
求球队比分资料.zip (7.2 KB, 下载次数: 9)

2013-8-18 16:12 上传

点击文件名下载附件

wudixin96

这个应该不难的

wx486

初学网抓，不知道代码是否符合要求，请测试。

1. Sub ie()
   
2.     With CreateObject("internetexplorer.application")
   
3.         .navigate "http://bf.bet007.com/Over1_cn.htm"
   
4.         .Visible = True
   
5.         Do Until .readystate = 4
   
6.             DoEvents
   
7.         Loop
   
8.         .document.all("matchdate").innertext = Range("b1").Text
   
9.         .document.all("Submit")(0).Click
   
10.         Do Until .readystate = 4 Or .Busy
    
11.             DoEvents
    
12.         Loop
    
13.         For i = 0 To .document.all.tags("table").Length - 1
    
14.             If InStr(.document.all.tags("table")(i).innertext, "主场球队") Then
    
15.                 k = i
    
16.                 Exit For
    
17.             End If
    
18.         Next
    
19.         Set t = .document.all.tags("table")(k).all.tags("table")
    
20.         For i = 0 To t.Length - 1
    
21.             If InStr(t(i).innertext, "赛事时间") Then
    
22.                 k = i
    
23.                 Exit For
    
24.             End If
    
25.         Next
    
26.         Set tt = t(k)
    
27.         For i = 0 To tt.Rows.Length - 1
    
28.             For j = 0 To tt.Rows(i).Cells.Length - 1
    
29.                 Cells(i + 2, j + 1) = tt.Rows(i).Cells(j).innertext
    
30.             Next
    
31.         Next
    
32.     End With
    
33.     MsgBox "ok"
    
34. End Sub

复制代码

wx486

请看附件
球队比分.zip (12.21 KB, 下载次数: 14)

2013-8-19 11:47 上传

点击文件名下载附件

我爱你！

我想抓的结果是B1l输入日期后当天完场比分，可不可实现？

我爱你！

wx486 发表于 2013-8-19 11:47
请看附件

测试不出来

我想抓的结果是B1l输入日期后当天完场比分，可不可实现？

wx486

我爱你！ 发表于 2013-8-19 20:34
测试不出来

我想抓的结果是B1l输入日期后当天完场比分，可不可实现？

请再测试一下。
球队比分.rar (33.96 KB, 下载次数: 18)

2013-8-20 18:18 上传

点击文件名下载附件

若还是不成功可将“Do Until .readystate = 4 And Timer > t1 + 5”的5改为更大一点的数字试试。

1. Sub ie()
   
2.     Dim t As Object, tt As Object, i%, j%, k%, t1
   
3.     With CreateObject("internetexplorer.application")
   
4.         .navigate "http://bf.bet007.com/Over1_cn.htm"
   
5.         .Visible = True
   
6.         Do Until .readystate = 4
   
7.             DoEvents
   
8.         Loop
   
9.         .document.all("matchdate").innertext = Range("b1").Text
   
10.         .document.all("Submit")(0).Click
    
11.         t1 = Timer
    
12.         Do Until .readystate = 4 And Timer > t1 + 5
    
13.             DoEvents
    
14.         Loop
    
15.         For i = 0 To .document.all.tags("table").Length - 1
    
16.             If InStr(.document.all.tags("table")(i).innertext, "主场球队") Then
    
17.                 k = i
    
18.                 Exit For
    
19.             End If
    
20.         Next
    
21.         Set t = .document.all.tags("table")(k).all.tags("table")
    
22.         For i = 0 To t.Length
    
23.             If InStr(t(i).innertext, "赛事时间") Then
    
24.                 k = i
    
25.                 Exit For
    
26.             End If
    
27.         Next
    
28.         Set tt = t(k)
    
29.         Sheet1.UsedRange.Offset(1).Clear
    
30.         Sheet1.Range([e:e], [g:g]).NumberFormatLocal = "@"
    
31.         For i = 0 To tt.Rows.Length - 1
    
32.             For j = 0 To tt.Rows(i).Cells.Length - 1
    
33.                 Cells(i + 2, j + 1) = tt.Rows(i).Cells(j).innertext
    
34.             Next
    
35.         Next
    
36.         .Quit
    
37.     End With
    
38.     MsgBox "ok"
    
39. End Sub

复制代码

wx486

换了算法，代码如下。

1. Sub xmlhttp()
   
2. Dim arr, brr(1 To 10000, 1 To 8), i%, j%, k%, reg As Object, matches, ma
   
3. Set reg = CreateObject("vbscript.regexp")
   
4. With reg
   
5.     .Global = True
   
6.     .Pattern = ">([^<>]+)<"
   
7. End With
   
8. With CreateObject("msxml2.xmlhttp")
   
9.     .Open "post", "http://bf.bet007.com/Over_matchdate.aspx", False
   
10.     .SetRequestHeader "content-type", "application/x-www-form-urlencoded"
    
11.     .send "matchdate=" & [b1].Value & "&Submit=%B2%E9%D1%AF&team=&sclass="
    
12.     s = .responsetext
    
13. End With
    
14. arr = Filter(Split(Split(Split(s, "id=""schedule"">")(1), "</div>")(0), "<tr"), "</tr>")
    
15. For i = 1 To UBound(arr)
    
16.     Set matches = reg.Execute(Replace(arr(i), " ", ""))
    
17.     If matches.Count > 3 Then
    
18.         k = k + 1
    
19.         If matches(2).submatches(0) = "推迟" Or matches(2).submatches(0) = "待定" Then
    
20.             For j = 1 To 4
    
21.                 brr(k, j) = matches(j - 1).submatches(0)
    
22.             Next
    
23.             brr(k, 6) = matches(4).submatches(0)
    
24.             brr(k, 8) = "析亚欧"
    
25.         Else
    
26.             For j = 1 To 7
    
27.                 brr(k, j) = matches(j - 1).submatches(0)
    
28.             Next
    
29.             brr(k, 8) = "析亚欧"
    
30.         End If
    
31.     End If
    
32. Next
    
33. [a1].CurrentRegion.Offset(2).ClearContents
    
34. [a3].Resize(UBound(brr), 8) = brr
    
35. MsgBox "ok"
    
36. End Sub
    
37. 
    

复制代码

[tr]

我爱你！

谢谢！
8楼wx486老师代码还不是我想用的结果，请帮忙看看附件。 球队比分（求）.zip (207.57 KB, 下载次数: 10)

2013-8-25 22:31 上传

点击文件名下载附件

wx486

我爱你！ 发表于 2013-8-25 22:26
谢谢！
8楼wx486老师代码还不是我想用的结果，请帮忙看看附件。

你的要求我没仔细看，你先看8楼的附件能用不能？