转自ExcelHome论坛suwenkai的回答，根据需求已作修改
Sub 百度地图广州电脑()
Dim url, html, js
Cells.ClearContents
br = [{"店名","地址","电话"}]
Range("a1:c1") = br
url = ""
Set html = CreateObject("htmlfile")
Set js = CreateObject("scriptcontrol")
js.Language = "jscript"
For p = 1 To 5 '搜索结果页面的1-5页
With CreateObject("msxml2.xmlhttp")
url = "http://map.baidu.com/?newmap=1"
url = url & "&reqflag=pcmap"
url = url & "&biz=1"
url = url & "&from=webmap"
url = url & "&qt=s"
url = url & "&from=webmap"
url = url & "&c=257"
url = url & "&pl_data_type=cater"
url = url & "&pl_sub_type=电脑" '关键词
url = url & "&pl_price_section=0%2C%2B"
url = url & "&pl_sort_type=data_type"
url = url & "&pl_sort_rule=0"
url = url & "&pl_discount2_section=0%2C%2B"
url = url & "&pl_groupon_section=0%2C%2B"
url = url & "&pl_cater_book_pc_section=0%2C%2B"
url = url & "&pl_ticket_book_flag_section=0%2C%2B"
url = url & "&pl_movie_book_section=0%2C%2B"
url = url & "&pl_business_type=cater"
url = url & "&pl_business_id="
url = url & "&pl_activity_gwj_section=0%2C%2B"
url = url & "&wd=电脑" '关键词
url = url & "&pn=1"
url = url & "&db=0"
url = url & "&wd2="
url = url & "&sug=0"
url = url & "&da_src=pcmappg.poi.page"
url = url & "&on_gel=1"
url = url & "&src=7"
url = url & "&gr=3"
url = url & "&l=12"
url = url & "&addr=0"
url = url & "&nn=" & (p - 1) * 10
url = url & "&tn=B_NORMAL_MAP"
url = url & "&ie=utf-8"
url = url & "&t=1412423900383"
.Open "get", url, False
.send
js.addcode ("suwenkai = " & .responsetext)
slen = js.eval("suwenkai.content.length") - 1
For i = 0 To slen
n = n + 1
Cells(n + 1, 1) = js.eval("suwenkai.content[" & i & "].name")
Cells(n + 1, 2) = js.eval("suwenkai.content[" & i & "].addr")
Cells(n + 1, 3) = js.eval("suwenkai.content[" & i & "].tel")
Next
End With
Next
End Sub
需要网抓，得会写代码。或者出门右转X宝找人弄。
不愿花钱不会代码，只能一个个复制了。
这个要写个小程序来解决
内容全部来源于网络收集，如有侵权，请联系网站删除：QQ：24596024