东方财富网天天练

mckawayi

按照您的代码，多页取值，就会发现某些页面会出现“403“禁止访问提示。。。。
Sub t()
    Dim html, db, i%, j%, k%, rowx, TD, TR, arrdata(1 To 10000, 1 To 18)
    Set html = CreateObject("htmlfile")
    For k = 1 To 100
        With CreateObject("msxml2.xmlhttp")
            .Open "GET", "http://data.eastmoney.com/bbsj/201412/yjyg/" & k & ".html", False  '以取第1页数据为例
            .send
                        Do Until .readyState = 4
                             DoEvents
                        Loop
                        If .Status <> 200 Then
                            If r < 10 Then
                                 r = r + 1
                            Else
                                  MsgBox "无法打开东方财富网数据中心指定网页" & vbCrLf & vbCrLf & "http://data.eastmoney.com/bbsj/201412/yjyg/" & k & ".html" & vbCrLf & vbCrLf & "Http状态：" & .Status
                                  End
                            End If
                        End If
        End With
    Next
End Sub

大神请出手相助！！！

onlycxb

mckawayi 发表于 2015-3-10 22:54
按照您的代码，多页取值，就会发现某些页面会出现“403“禁止访问提示。。。。
Sub t()
    Dim html, db ...

简单测试一下（代码未优化），运行1000次没有出错

1. Option Explicit
   
2. 
   
3. Sub t()
   
4.     Dim html, db, i%, j%, k%, rowx, TD, TR, arrdata(1 To 100000, 1 To 18), P
   
5.    
   
6.     For P = 1 To 1000
   
7.     Set html = CreateObject("htmlfile")
   
8.     With CreateObject("msxml2.xmlhttp")
   
9.         .Open "GET", "http://data.eastmoney.com/bbsj/201412/yjbb/ggrq/desc/" & P & ".html", False '以取第1页数据为例
   
10.         .send
    
11.         html.body.innerhtml = .responsetext
    
12.     End With
    
13. 
    
14.     Set db = html.all.tags("table")
    
15.     For i = 0 To db.Length - 1
    
16.         If db(i).classname = "tab1" Then
    
17.             Set rowx = db(i).Rows
    
18.             For Each TR In rowx
    
19.                 j = j + 1
    
20.                 k = 0
    
21.                 For Each TD In TR.Cells
    
22.                      k = k + 1
    
23.                 If j > 2 Then arrdata(j - 2, k) = TD.innertext
    
24.                 Next TD
    
25.             Next TR
    
26.         End If
    
27.     Next i
    
28.     Set html = Nothing
    
29.     Set db = Nothing
    
30.     Set rowx = Nothing
    
31.     Next P
    
32.     Cells.Clear
    
33.     [a1].Resize(j - 2, 18) = arrdata
    
34. End Sub
    

复制代码

onlycxb

10.东方财富网股票的财务分析数据更新入EXCEL工作表的VBA代码  网页：http://f10.eastmoney.com/f10_v2/ ... .aspx?code=sz000898

1. Sub t()
   
2.     Dim html, db, i%, j%, k%, tr, td, arr(1 To 100000, 1 To 10)
   
3.     Set html = CreateObject("htmlfile")
   
4.     With CreateObject("msxml2.xmlhttp")
   
5.         .Open "GET", "http://f10.eastmoney.com/f10_v2/FinanceAnalysis.aspx?code=sz000898 ", False
   
6.         .send
   
7.         html.write .responsetext
   
8.     End With
   
9.     Set db = html.all.tags("table")
   
10.     For i = 0 To db.Length - 1
    
11.         If db(i).classname = "needScroll" Or db(i).ID = "BBMX_table" Then
    
12.             For Each tr In db(i).Rows
    
13.                 j = j + 1
    
14.                 k = 0
    
15.                 For Each td In tr.Cells
    
16.                     k = k + 1
    
17.                     arr(j, k) = td.innertext
    
18.                 Next td
    
19.             Next tr
    
20.         End If
    
21.     Next i
    
22.     [a1].Resize(j, k) = arr
    
23. End Sub
    

复制代码

VBA万岁

onlycxb 发表于 2015-3-10 07:46
6.外汇行情

7楼第12句循环代码中的i是否应该改为n或其他非i变量？——这样方可获取六大银行（中国银行、农业银行、工商银行、建设银行、交通银行、招商银行）的外汇行情数据，否则只能获取中国银行的外汇行情数据：

1. Sub 更新外汇行情数据2()
   
2. Dim html As Object, arrdata(1 To 100000, 1 To 8), Db, Url$
   
3.     Dim i%, j%, tr, td
   
4.     Url = "http://quote.eastmoney.com/center/forexlist.html"
   
5.     Set html = CreateObject("htmlfile")
   
6.     With CreateObject("msxml2.xmlhttp")
   
7.         .Open "GET", Url, False
   
8.         .send
   
9.         html.body.innerhtml = StrConv(.ResponseBody, vbUnicode, &H804)
   
10.     End With
    
11.     Set Db = html.all.tags("table")
    
12.     For n = 0 To Db.Length - 1
    
13.         If Db(n).classname = "data-table" Then
    
14.             arrdata(n + i + 1, 1) = html.all.tags("ul")("yhpj").ChildNodes(n).innertext
    
15.             For Each tr In Db(n).Rows
    
16.                 i = i + 1
    
17.                 j = 0
    
18.                 For Each td In tr.Cells
    
19.                     j = j + 1
    
20.                     arrdata(n + i + 1, j) = td.innertext
    
21.                 Next td
    
22.             Next tr
    
23.         End If
    
24.     Next
    
25.     Cells.Clear
    
26.     [a1].Resize(i, UBound(arrdata, 2)) = arrdata
    
27. End Sub
    

复制代码

VBA万岁

VBA万岁 发表于 2015-3-11 14:56
7楼第12句循环代码中的i是否应该改为n或其他非i变量？——这样方可获取六大银行（中国银行、农业银行、工 ...

附件：
提取银行外汇行情数据.zip (76.95 KB, 下载次数: 276)

2015-3-13 10:03 上传

点击文件名下载附件

mckawayi

Option Explicit

Sub t()
    Dim html, db, i%, j%, k%, rowx, TD, TR, arrdata(1 To 100000, 1 To 18), P
   
    For P = 1 To 1000
    Set html = CreateObject("htmlfile")
    With CreateObject("msxml2.xmlhttp")
        .Open "GET", "http://data.eastmoney.com/bbsj/201412/yjbb/ggrq/desc/" & P & ".html", False '以取第1页数据为例
        .send
            Do Until .readyState = 4
                 DoEvents
            Loop
            If .Status <> 200 Then
                      MsgBox "无法打开东方财富网数据中心指定网页" & vbCrLf & vbCrLf & "http://data.eastmoney.com/bbsj/201412/yjbb/ggrq/desc/" & P & ".html" & vbCrLf & vbCrLf & "Http状态：" & .Status
                      End
            End If
        html.body.innerhtml = .responsetext
    End With

    Set db = html.all.tags("table")
    For i = 0 To db.Length - 1
        If db(i).classname = "tab1" Then
            Set rowx = db(i).Rows
            For Each TR In rowx
                j = j + 1
                k = 0
                For Each TD In TR.Cells
                     k = k + 1
                If j > 2 Then arrdata(j - 2, k) = TD.innertext
                Next TD
            Next TR
        End If
    Next i
    Set html = Nothing
    Set db = Nothing
    Set rowx = Nothing
    Next P
    Cells.Clear
    [a1].Resize(j - 2, 18) = arrdata
End Sub

大神，只要在您的代码中加入红色部分，就会发现某些页面会出现“403禁止访问”提示！
遍历提取业绩预告数据，访问页面http://data.eastmoney.com/bbsj/201503/yjyg/P.html时某些页面也会出现相同“禁止访问”提示！
遍历股票提取龙虎榜数据时，访问页面[url=http://data.eastmoney.com/stock/lhb/xxxxxx.html]http://data.eastmoney.com/stock/lhb/xxxxxx.html时某些页面也会出现相同“禁止访问”提示！

禁止访问了，后续数据提取自然就无法完成。。。倘若这个问题不解决，从东方财富网提取数据就变得极不可靠了。
Http头信息有cookie内容，是否因为这些页面有防盗链而无法正常访问？请大神相助！

onlycxb

mckawayi 发表于 2015-3-12 09:43
Option Explicit

Sub t()

1.readyState是Ie属性。想想用这里合适吗？
2.没有cookie，已经取出数据，还有必要吗？

mckawayi

onlycxb 发表于 2015-3-12 16:38
1.readyState是Ie属性。想想用这里合适吗？
2.没有cookie，已经取出数据，还有必要吗？

Option Explicit

Sub t()
    Dim html, db, i%, j%, k%, rowx, TD, TR, arrdata(1 To 100000, 1 To 18), P
   
    For P = 1 To 37
    Set html = CreateObject("htmlfile")
    With CreateObject("msxml2.xmlhttp")
        .Open "GET", "http://data.eastmoney.com/bbsj/201412/yjyg/ & P & ".html", False '以取第1页数据为例
        .send
            If .Status <> 200 Then
                      MsgBox  "Http状态：" & .Status
                      End
            End If
       'html.body.innerhtml = .responsetext
    End With
Next P

End Sub

即使去掉readystate语句，某些页面依然禁止访问。。。

onlycxb

具体不清，有可能同一IP地址发送请求过多，遭到服务器智能屏蔽

onlycxb

11、东方财富网 > 数据中心 > 年报季报 > 预约时间
2014年年报业绩大全                               

个股业绩报表：

1. Sub test()
   
2.      Cells.Clear
   
3.      For p = 1 To 3
   
4.          Set s = IIf(p = 1, Cells(Rows.Count, 1).End(xlUp), Cells(Rows.Count, 1).End(xlUp).Offset(1, 0))
   
5.          With ActiveSheet.QueryTables.Add(Connection:="URL;http://data.eastmoney.com/bbsj/201412/yysj/sc/asc/" & p & ".html", Destination:=s)
   
6.              .Refresh BackgroundQuery:=False
   
7.          End With
   
8.          If p > 1 Then s.EntireRow.Delete
   
9.      Next p
   
10. End Sub
    
11.   

复制代码