[已解决]下拉菜单的网页数据如何导入到EXCEL

fengmodel

目标网址为请见附件
已经尝试新建web查询,数据导入不了
涉及下拉菜单,只有选定特定内容之后才会显示数据

选定公司和某联赛,显示选定公司对某联赛开出的让球盘\大小盘\标准盘
因为是要全部的数据,所以图中划掉的部分不用输入和修改直接点击确认就是显示全部数据
将显示的数据手动复制粘贴速度很慢,那这种带有下拉菜单的网页,如何导出数据呢?
有位老师出的代码在下面，请有经验的帮忙看一下，F8执行后提示错误代码是424，网络响应时间太长？！
以下代码如何直接修改？或者用post发包、xmlhttp发包怎么编写呢？



问题附件.rar (207.33 KB, 下载次数: 38)

2013-3-26 16:05 上传

点击文件名下载附件

**************************分隔线************************************

1. Sub cc()
   
2. Dim Str$
   
3. Str = "网址请看附件,本人无权发"
   
4. With CreateObject("InternetExplorer.Application")
   
5. .Visible = True
   
6. .Navigate Str
   
7. t = Timer
   
8. Do While .Busy Or t + 3 > Timer
   
9.   DoEvents
   
10. Loop
    
11. For m = 0 To 2
    
12.   .Document.all("leagueID")(m).Value = "36"
    
13.   .Document.Forms(m).submit    '//此段代码执行时，提示错误
    
14.   t = Timer
    
15.   Do While .Busy Or t + 3 > Timer
    
16.    DoEvents
    
17.   Loop
    
18.   k = 0
    
19.   Set r = .Document.all.tags("td")
    
20.   If m = 2 Then n = 15 Else n = 16
    
21.   ReDim Arr(1 To r.Length, 1 To n)
    
22.   For i = n + 4 To r.Length - 1
    
23.    Arr(i \ n + 1, k Mod n + 1) = r(i).innerText
    
24.    k = k + 1
    
25.   Next i
    
26.   With Sheets(m + 1)
    
27.    .[a1].Resize(k, n) = Arr
    
28.    .Range(.Cells(1, n - 3), .Cells(1, n)).Delete 2
    
29.   End With
    
30. Next
    
31. .Quit
    
32. End With
    
33. End Sub

复制代码

最佳答案

月排行榜 / 总排行榜

wcymiss

2013-3-29 13:39

1. Sub cs()
   
2.     Dim myXml As Object, s, myClip As Object
   
3.     Set myXml = CreateObject("msxml2.xmlhttp")
   
4.     Set myClip = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
   
5.     With myXml
   
6.         .Open "POST", "http://cn.zso8.com/odds/search/", False
   
7.         .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
   
8.         .send "type=2&CompanyID=11|澳门&leagueID=36&teamID=0&kind=1&port=&odds1=&do0=确定"
   
9.         s = .responsetext
   
10.         s = Mid(s, InStr(s, "<table border=""0"""))
    
11.         s = Left(s, InStr(s, "</table>") + 7)
    
12.     End With
    
13.     With myClip
    
14.         .SetText s
    
15.         .PutInClipboard
    
16.     End With
    
17.     Cells.Clear
    
18.     Range("a1").Select
    
19.     ActiveSheet.Paste
    
20. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

设断点看下。

fengmodel

hwc2ycy 发表于 2013-3-26 16:37
设断点看下。

单步执行到第12行出现错误代码424提示

wcymiss

1. Sub cs()
   
2.     Dim myXml As Object, s, myClip As Object
   
3.     Set myXml = CreateObject("msxml2.xmlhttp")
   
4.     Set myClip = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
   
5.     With myXml
   
6.         .Open "POST", "http://cn.zso8.com/odds/search/", False
   
7.         .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
   
8.         .send "type=2&CompanyID=11|澳门&leagueID=36&teamID=0&kind=1&port=&odds1=&do0=确定"
   
9.         s = .responsetext
   
10.         s = Mid(s, InStr(s, "<table border=""0"""))
    
11.         s = Left(s, InStr(s, "</table>") + 7)
    
12.     End With
    
13.     With myClip
    
14.         .SetText s
    
15.         .PutInClipboard
    
16.     End With
    
17.     Cells.Clear
    
18.     Range("a1").Select
    
19.     ActiveSheet.Paste
    
20. End Sub

复制代码

hwc2ycy

做个标记，一直要学XMLHTTP的。

kangatang

hwc2ycy 发表于 2013-3-26 16:37
设断点看下。

The Best Answer reward is a good way to encourage and insprit the people who give answers.
Thant's why Excelpx are uprising overwhelming Excelhome.