GBKEE

回復 2# Michelle-W
google  會有流量管制限制資料的下載
試試看

1. Option Explicit
   
2. Sub 資料搜尋()
   
3.     Dim IE As Object, MyState As String, E As Object
   
4.     Dim Sh As Worksheet, Msg As Boolean, i As Integer
   
5.     With Workbooks.Open(ThisWorkbook.Path & "\資料處理.xlsm")  '打開另一個excel做為資料儲存
   
6.         Set Sh = .Sheets("SHEET2")
   
7.         Sh.Cells.Clear
   
8.     End With
   
9.     Set IE = CreateObject("InternetExplorer.Application")
   
10.     With IE
    
11.         .Visible = True 'False
    
12.         .Navigate ("https://www.google.com")
    
13.     End With
    
14.     MyState = ThisWorkbook.Sheets("sheet1").Range("A2") 'B2為關鍵字,打開IE
    
15.     While IE.Busy Or IE.readyState <> 4:  DoEvents: Wend '確保網頁完整打開
    
16.     For Each E In IE.Document.getelementsbytagname("input")
    
17.         If E.Name = "q" Then: E.Value = MyState: Exit For  '找到input,填入輸入值
    
18.     Next
    
19.     While IE.Busy Or IE.readyState <> 4:  DoEvents: Wend '確保網頁完整打開
    
20.     IE.Document.getElementsByName("btnG").Item.Click '按下搜尋紐
    
21. ag:   '下載搜尋結果
    
22.     Msg = False
    
23.     While IE.Busy Or IE.readyState <> 4:  DoEvents: Wend '確保網頁完整打開
    
24.     'FnWait (0.7)  '等待時間 :等候網頁整理完畢
    
25.     Do While IE.Busy: DoEvents: Loop
    
26.     For Each E In IE.Document.ALL.TAGS("H3")
    
27.         i = i + 1
    
28.         Sh.Cells(Sh.Range("A" & Sh.Rows.Count).End(xlUp).Row + 1, 1) = E.ALL(0).innertext
    
29.         Sh.Cells(Sh.Range("B" & Sh.Rows.Count).End(xlUp).Row + 1, 2) = E.ALL(0).HREF
    
30.         Application.StatusBar = E.ALL(0).innertext
    
31.     Next
    
32.     For Each E In IE.Document.ALL.TAGS("span")
    
33.         If E.innertext = "下一頁" Then
    
34.             Msg = True
    
35.             E.Click
    
36.             Exit For
    
37.         End If
    
38.     Next
    
39.     If Msg Then GoTo ag
    
40.     If IE.LocationURL Like "https://ipv4.google.com/sorry/IndexRedirect?*" Then  '** 被 google  流量管制
    
41.         MsgBox "請先到 IE 輸入:驗證數字,再回到Excel 按下確定鍵 ", , "google  流量管制"
    
42.         GoTo ag
    
43.     End If
    
44.     Application.StatusBar = MyState & " 共 google " & i
    
45.     IE.Quit
    
46. End Sub
    

複製代碼

GBKEE

回復 5# Michelle-W
2003沒有錯誤
可修正一下

1. Sh.Cells(Sh.Range("A" & Sh.Rows.Count).End(xlUp).Row + 1, 1) = E.ALL(0).innertext

複製代碼

GBKEE

回復 6# Michelle-W

3#的程式碼有誤已更正 因少了With

1. With Workbooks.Open(ThisWorkbook.Path & "\資料處理.xlsm")  '打開另一個excel做為資料儲存
   
2.     Set Sh = .Sheets("SHEET1")
   
3.     Sh.Cells.Clear
   
4. End With

複製代碼

GBKEE

回復 9# c_c_lai
更新3#的程式碼
2003版 執行如下圖

下載 (13.43 KB)

2016-8-19 11:11

GBKEE

回復 12# c_c_lai

3# 的程式碼已更正請再試試看
2003中一直沒這錯誤

GBKEE

回復 14# c_c_lai
眼睛看好了.
請參考看看

1. ag:   '下載搜尋結果
   
2.     Msg = False
   
3.     FnWait 1   ''等待時間 :有錯誤時,調整等候的時間,待網頁整理完畢
   
4.     '************************************************************
   
5.   ' While IE.Busy Or IE.readyState <> 4:  DoEvents: Wend '確保網頁完整打開
   
6.   '** While ** 2003, IE8 , Adsl 5M/384K.一直沒錯誤啊
   
7.   
   
8.   '*************************************************************
   
9.     For Each E In IE.Document.ALL.TAGS("H3")
   
10.         i = i + 1
    
11.         Sh.Cells(Sh.Range("A" & Sh.Rows.Count).End(xlUp).Row + 1, 1) = E.ALL(0).innertext
    
12.         Sh.Cells(Sh.Range("B" & Sh.Rows.Count).End(xlUp).Row + 1, 2) = E.ALL(0).HREF
    
13.         Application.StatusBar = E.ALL(0).innertext
    
14.     Next

複製代碼