网页抓取分享

onlycxb

VBA万岁 发表于 2014-11-13 12:48
加上如下一句并将代码加入功能区以方便更新数据：
ActiveSheet.UsedRange.Delete

ActiveSheet.cells.clear

VBA万岁

onlycxb 发表于 2014-11-13 12:52
ActiveSheet.cells.clear

测试无误，这样就无需在功能区设置按钮了。

onlycxb

CHINAAIRLINES CARGO http://club.excelhome.net/thread-1179166-1-1.html

VBA万岁

onlycxb 发表于 2015-1-12 09:47
CHINAAIRLINES CARGO http://club.excelhome.net/thread-1179166-1-1.html

多谢分享！

29151429

。。。。。。。

onlycxb

分享：[url]http://list.yhd.com/c33797-0-0/[/url]

1. Sub t()
   
2.     Dim Xml As Object, html As Object
   
3.     Dim Url As String, S As String
   
4.     Dim tb As Object, i As Long
   
5.     Url = "http://list.yhd.com/searchPage/c33797-0-81144/b/a-s1-v0-p2-price-d0-f0-m1-rt0-pid-mid0-k"
   
6.     Set html = CreateObject("htmlfile")
   
7.     With CreateObject("MSXML2.XMLHTTP")
   
8.         .Open "GET", Url, False
   
9.         .send
   
10.         S = .responseText
    
11.         S = Replace(S, "\r", "")
    
12.         S = Replace(S, "\n", "")
    
13.         S = Replace(S, "\t", "")
    
14.         S = Replace(S, "", "")
    
15.         html.body.innerhtml = S
    
16.     End With
    
17.     Set tb = html.all.tags("a")
    
18.     For i = 0 To tb.Length - 1
    
19.         If tb(i).classname = "title" Then
    
20.             Debug.Print tb(i).innertext
    
21.             Debug.Print Split(Split(tb(i).outerHtml, "href=""")(1), """ target=_blank pmId")(0)
    
22.         End If
    
23.     Next i
    
24. End Sub

复制代码

chinakey

感谢 冬雨师傅 (onlycxb ) ,这串代码研究了好几天了 ,师傅一出手就搞定了!赞!

chinakey

感谢 冬雨师傅 onlycxb ,这段代码对俺来说 真心有用!谢谢

chinakey

感谢冬雨师傅 分享 自己的心得,还有那个俺误认为 json的困扰也随之帮俺解决了 感谢分享!

onlycxb

1. Sub Main()
   
2.     Dim strText As String, js As Object, tb As Object, i As Integer, Url As String
   
3.    Url = "http://list.yhd.com/searchPage/c33797-0-0/b/a-s1-v0-p2-price-d0-f0-m1-rt0-pid-mid0-k"
   
4.     Set js = CreateObject("scriptcontrol")
   
5.     js.Language = "javascript"
   
6.     With CreateObject("MSXML2.XMLHTTP")
   
7.         .Open "GET", Url, False
   
8.         .send
   
9.         strText = js.Eval("var a=" & .responseText & ";a.value")         '取出json对象的属性名为“value”的值
   
10.         Debug.Print strText
    
11.     End With
    
12.     With CreateObject("htmlfile")
    
13.         .body.innerhtml = strText
    
14.         Set tb = .all.tags("a")
    
15.     End With
    
16.     For i = 0 To tb.Length - 1
    
17.         If tb(i).classname = "title" Then
    
18.             Debug.Print tb(i).innertext
    
19.             Debug.Print Split(Split(tb(i).outerHtml, "href=""")(1), """ target=_blank pmId")(0)
    
20.         End If
    
21.     Next i
    
22. End Sub
    

复制代码