如何把百度地图左边的多页搜索结果一次性导出excel文件啊

yueshang0

  刚才发的不是求助帖 现在我重发一下 不知道有没有违规 如有违规版主见谅啊

这个要怎么做啊 大神 们 帮帮忙啊 这个工作要一个个城市的搜下来 每个城市有上千条一页一页的复制 还要 排版 人都要崩溃了

ccwan

这个问题还是有点难度的

1. Sub cc()
   
2.     Cells.ClearContents
   
3.     ReDim arr(1 To 1000, 1 To 3)
   
4.     Set Js = CreateObject("msscriptcontrol.scriptcontrol")
   
5.     Js.Language = "JavaScript"
   
6.     tt = Js.Eval("(new Date).getTime();")
   
7.     With CreateObject("MSXML2.XMLHTTP")
   
8.         For p = 0 To 4
   
9.             .Open "get", "http://map.baidu.com/?newmap=1&reqflag=pcmap&biz=1&from=webmap&qt=s&from=webmap&c=191&pl_data_type=life&pl_sub_type=KTV&pl_price_section=0%2C%2B&pl_sort_type=data_type&pl_sort_rule=0&pl_discount2_section=0%2C%2B&pl_groupon_section=0%2C%2B&pl_cater_book_pc_section=0%2C%2B&pl_ticket_book_flag_section=0%2C%2B&pl_movie_book_section=0%2C%2B&pl_business_type=life&pl_business_id=&pl_activity_gwj_section=0%2C%2B&wd=ktv&pn=" & p & "&db=0&wd2=&sug=0&da_src=pcmappg.poi.page&on_gel=1&src=7&gr=3&b=(12948998.92,4744884.22;13034054.92,4792692.22)&l=12&addr=0&nn=" & p * 10 & "&tn=B_NORMAL_MAP&ie=utf-8&t=" & tt, False
   
10.             .send
    
11.             Js.addcode "function decode(str){return unescape(str.replace(/\u/g,'%u'));}"
    
12.             s = Js.Eval("decode('" & .responsetext & "')")
    
13.             t = Filter(Split(s, "[],"), "poi_address")
    
14.             For i = 0 To UBound(t)
    
15.                 Js.addcode "a={" & Split(t(i), ",""point""")(0) & "}"
    
16.                 k = k + 1
    
17.                 arr(k, 1) = Js.Eval("a.name")
    
18.                 arr(k, 2) = Js.Eval("a.phone")
    
19.                 arr(k, 3) = Js.Eval("a.poi_address")
    
20.             Next
    
21.         Next
    
22.     End With
    
23.     [a1:c1] = Array("名称", "电话", "地址")
    
24.     [a2].Resize(UBound(arr), 3) = arr
    
25. End Sub

复制代码

ccwan

代码还可以简化下

1. Sub cc()
   
2.     On Error Resume Next
   
3.     Cells.ClearContents
   
4.     ReDim arr(1 To 1000, 1 To 3)
   
5.     Set Js = CreateObject("msscriptcontrol.scriptcontrol")
   
6.     Js.Language = "JavaScript"
   
7.     tt = Js.eval("(new Date).getTime();")
   
8.     With CreateObject("MSXML2.XMLHTTP")
   
9.         For p = 0 To 4
   
10.             .Open "get", "http://map.baidu.com/?&qt=s&wd=ktv&pn=" & p & "&b=(12948998.92,4744884.22;13034054.92,4792692.22)&l=12&nn=" & p * 10 & "&t=" & tt, False
    
11.             .send
    
12.             s = Js.eval("decodeURI('" & .responsetext & "')")
    
13.             t = Filter(Split(s, "[],"), "poi_address")
    
14.             For i = 0 To UBound(t)
    
15.                 Js.addcode "a={" & Split(t(i), ",""point""")(0) & "}"
    
16.                 k = k + 1
    
17.                 arr(k, 1) = Js.eval("a.name")
    
18.                 arr(k, 2) = Js.eval("a.phone")
    
19.                 arr(k, 3) = Js.eval("a.poi_address")
    
20.             Next
    
21.         Next
    
22.     End With
    
23.     [a1:c1] = Array("名称", "电话", "地址")
    
24.     [a2].Resize(UBound(arr), 3) = arr
    
25. End Sub

复制代码

ccwan

网速慢的恶果   

tianzhiliabc

是不是需要这样的效果？

搜索结果

yueshang0

tianzhiliabc 发表于 2014-5-19 10:26
是不是需要这样的效果？

搜索结果

对对 就是这样

yueshang0

ccwan 发表于 2014-5-19 09:43
代码还可以简化下

非常感谢 大神 你就是我远方明亮的灯塔啊

yueshang0

tianzhiliabc 发表于 2014-5-19 10:26
是不是需要这样的效果？

搜索结果

看起来好简单的样子 大神你这个是什么软件  哪里下载啊

yueshang0

ccwan 发表于 2014-5-19 09:43
代码还可以简化下

内存溢出 什么情况

LMY123

网页抓取学习中