vba爬取网页 提示 拒绝访问！求助

平平淡淡的天使

之前我爬取都很正常，突然就不行了，我也很好奇。请各位大师帮忙下！

平平淡淡的天使

Sub Main_fangtianxia1()
    Dim i As Long, C As Integer
    Dim arr
    Dim l_n As Long
    Dim liem
    Dim a As String, b As String
    Dim t
    Dim e As Object
    Dim ys As Integer
    Dim shuzu()
    Application.ScreenUpdating = False
    t = Timer
    Range("a1:J10000").Cells.ClearContents
    liem = Array("楼盘名称", "均价", "地址", "装修状态", "户数", "交付时间", "开盘时间", "销售状态", "区域楼盘", "物业类别")
        Range("A1:J1") = liem
    With CreateObject("MSXML2.XMLHTTP")
      .Open "GET", "http://newhouse.nb.fang.com/house/s/", False
'      .setRequestHeader "If-Modified-Since", "0"
      .Send
       a = StrConv(.ResponseBody, vbUnicode, &H804)
       ys = Split(Split(a, "</span>/")(1), "&nbsp")(0)
    End With
ReDim shuzu(1 To 20 * ys, 1 To 10)
l_n = Range("A65536").End(xlUp).Row + 1
  For C = 1 To ys
    Set e = CreateObject("MSXML2.XMLHTTP")
        e.Open "GET", "http://newhouse.nb.fang.com/house/s/b9" & C & "/?ctm=1.nb.xf_search.page." & C + 1, False
'        e.setRequestHeader "If-Modified-Since", "0"
        e.Send
        a = StrConv(e.ResponseBody, vbUnicode, &H804) '&H804 简体中文
        arr = Split(a, "class=""duibi"" onclick=""add('")
        For i = 1 To UBound(arr)
            arr(i) = Split(arr(i), "','")(0)
            arr(i) = "http://chengshizhiguanghd.fang.com/house/" & arr(i) & "/housedetail.htm"
            e.Open "GET", arr(i), False
            e.Send
            b = StrConv(e.ResponseBody, vbUnicode, &H804)
            shuzu(i + (C - 1) * 20, 1) = Split(Split(b, "<span  title=""")(1), "楼盘详情")(0)
            shuzu(i + (C - 1) * 20, 2) = Split(Split(b, "格：</span><em>" & Chr(10))(1), "</em></div>")(0)
            shuzu(i + (C - 1) * 20, 3) = Split(Split(b, "<div class=""list-right-text"">")(2), "</div>")(0)
            shuzu(i + (C - 1) * 20, 4) = Split(Split(Split(b, "装修状况：</div>")(1), ">" & Chr(10))(1), "<")(0)
            shuzu(i + (C - 1) * 20, 5) = Split(Split(Split(b, "</i>数：</div>")(1), ">")(1), "<")(0)
            shuzu(i + (C - 1) * 20, 6) = Split(Split(Split(b, "交房时间：</div>")(1), ">")(1), "<")(0)
            shuzu(i + (C - 1) * 20, 7) = Split(Split(Split(b, "盘时间：</div>")(1), ">")(1), "<")(0)
            shuzu(i + (C - 1) * 20, 8) = Split(Split(Split(b, "销售状态：</div>")(1), ">" & Chr(10))(1), "<")(0)
            shuzu(i + (C - 1) * 20, 9) = Split(Split(b, "楼盘"">")(1), "</")(0)
            shuzu(i + (C - 1) * 20, 10) = Split(Split(b, "<div class=""list-right"" title=""")(1), """")(0)
        Next
    Set e = Nothing
   Next
    Range("A" & l_n).Resize(UBound(shuzu), 10) = shuzu
    Erase shuzu
    MsgBox Timer - t
    Application.ScreenUpdating = True
End Sub
代码如上，我研究半天都解决不了，请各位大师帮忙啊

chentonny

请求头加个浏览器伪装一下。

719404338

网址改了：http://nb.newhouse.fang.com/house/s

1. Sub Main_fangtianxia()
   
2.     Dim i As Long, C As Integer
   
3.     Dim arr
   
4.     Dim l_n As Long
   
5.     Dim liem
   
6.     Dim a As String, b As String
   
7.     Dim t
   
8.     Dim e As Object
   
9.     Dim ys As Integer
   
10.    ' Dim shuzu()
    
11.     Application.ScreenUpdating = False
    
12.     t = Timer
    
13.     Range("a1:i10000").Cells.ClearContents
    
14.     liem = Array("楼盘名称", "均价", "地址", "装修状态", "户数", "交付时间", "开盘时间", "销售状态", "区域楼盘", "物业类别")
    
15.         Range("A1:J1") = liem
    
16.     With CreateObject("MSXML2.XMLHTTP")
    
17.       .Open "GET", "http://nb.newhouse.fang.com/house/s/", False
    
18. '      .setRequestHeader "If-Modified-Since", "0"
    
19.       .Send
    
20.        a = StrConv(.ResponseBody, vbUnicode, &H804)
    
21.        ys = Split(Split(a, "</span>/")(1), "&nbsp")(0)
    
22.     End With
    
23.   For C = 1 To ys
    
24.     Set e = CreateObject("MSXML2.XMLHTTP")
    
25.         e.Open "GET", "http://nb.newhouse.fang.com/house/s/b9" & C & "/?ctm=1.nb.xf_search.page." & C + 1, False
    
26. '        e.setRequestHeader "If-Modified-Since", "0"
    
27.         e.Send
    
28.         a = StrConv(e.ResponseBody, vbUnicode, &H804) '&H804 简体中文
    
29.         a = Replace(a, Chr(10), "")
    
30.         arr = Split(a, "class=""duibi"" onclick=""add('")
    
31.        ' ReDim shuzu(1 To UBound(arr), 1)
    
32.         For i = 1 To UBound(arr)
    
33.             l_n = Range("A65536").End(xlUp).Row + 1
    
34.             arr(i) = Split(arr(i), "','")(0)
    
35.             arr(i) = "http://chengshizhiguanghd.fang.com/house/" & arr(i) & "/housedetail.htm"
    
36.             e.Open "GET", arr(i), False
    
37.             e.Send
    
38.             b = StrConv(e.ResponseBody, vbUnicode, &H804)
    
39.             b = Replace(b, Chr(10), "")
    
40.             b = Replace(b, Chr(32), "")
    
41.             Cells(l_n, 1).Value = Split(Split(b, "<spantitle=""")(1), "楼盘详情")
    
42.             Cells(l_n, 2).Value = Split(Split(b, "格：</span><em>")(1), "</em></div>")
    
43.             Cells(l_n, 3).Value = Split(Split(b, "楼盘地址：</div><divclass=""list-right-text"">")(1), "</div>")
    
44.             Cells(l_n, 4).Value = Split(Split(b, "装修状况：</div><divclass=""list-right"">")(1), "<")
    
45.             Cells(l_n, 5).Value = Split(Split(b, "</i>数：</div><divclass=""list-right"">")(1), "</div>")
    
46.             Cells(l_n, 6).Value = Split(Split(b, "交房时间：</div><divclass=""list-right"">")(1), "</div>")
    
47.             Cells(l_n, 7).Value = Split(Split(b, "盘时间：</div><divclass=""list-right"">")(1), "<")
    
48.             Cells(l_n, 8).Value = Split(Split(b, "销售状态：</div><divclass=""list-right"">")(1), "</div>")
    
49.             Cells(l_n, 9).Value = Split(Split(b, "楼盘"">")(1), "</")(0)
    
50.             Cells(l_n, 10).Value = Split(Split(b, "<divclass=""list-right""title=""")(1), """")
    
51.         Next
    
52. '        Range("A" & l_n).Resize(UBound(shuzu), 1) = shuzu
    
53.     Erase arr
    
54.     Set e = Nothing
    
55.    Next
    
56.     MsgBox Timer - t
    
57.     Application.ScreenUpdating = True
    
58. End Sub

复制代码

chentonny

URL改了，用你原来的URL取不到数据。

平平淡淡的天使

719404338 发表于 2018-8-30 20:01
网址改了：http://nb.newhouse.fang.com/house/s

谢谢啊。，我以为我代码写错了。。

平平淡淡的天使

chentonny 发表于 2018-8-30 20:50
URL改了，用你原来的URL取不到数据。

这个爬取网页，还要时不时的修改一下URL了，谢谢了