使用VBA抓取網頁資料，大約不到200頁就會當掉，求解
- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
回復 3# clio
沒有別的網址可下載嗎?
測到1500頁跑近10分鐘, 40377 頁要跑很久請自己測試- Option Explicit
- Sub Ex()
- Dim Sh(1 To 2) As Worksheet, q As QueryTable, i As Long, Rng As Range
- Dim xTime As Date
- With ThisWorkbook
- Set Sh(1) = .Sheets(1)
- Set Sh(2) = .Sheets(2) '**.Sheets("工作表3")
- End With
- With Sh(1)
- '****這段是要刪除工作表1上有太多的 QueryTable (會當可能是在這)****
- For Each q In .QueryTables
- q.Delete
- Next
- '****這段是要刪除工作表1上QueryTable的名稱
- For i = .Names.Count To 1 Step -1
- .Names.Item(i).Delete
- Next
- '**設定你的外部查詢在固定的QueryTable上
- If .QueryTables.Count > 0 Then
- Set q = .QueryTables(1)
- Else
- Set q = .QueryTables.Add(Connection:="URL;http://www.passivecomponent.com/asp/search_chip.aspx?page=1" _
- , Destination:=.[A1])
- End If
- End With
- xTime = Time
- Application.ScreenUpdating = False
- For i = 1 To 40377
- With q
- .Connection = "URL;http://www.passivecomponent.com/asp/search_chip.aspx?page=" & i
- .WebFormatting = xlNone
- .RefreshStyle = xlInsertDeleteCells
- .AdjustColumnWidth = True
- .Refresh BackgroundQuery:=False
- DoEvents
- Set Rng = .ResultRange '**外部查詢的資料區
- If i = 1 Then
- Sh(2).UsedRange.Clear
- Sh(2).Range("A1").Resize(Rng.Rows.Count, Rng.Columns.Count) = Rng.Value
- Else
- Sh(2).Range("A" & Sh(2).Cells(Rows.Count, 1).End(xlUp).Row + 1).Resize(Rng.Rows.Count, Rng.Columns.Count) = Rng.Offset(1).Value
- End If
- End With
- Application.StatusBar = "下載開始: " & xTime & " 共 " & i & " 頁 ok " & Application.Text(Time - xTime, ["m分s秒"])
- Next
- Application.ScreenUpdating = True
- MsgBox Application.Text(Time - xTime, ["m分s秒"]) & " Finish"
- End Sub
|
|
|
|
|
|
|
|
發表於 2018-10-8 19:10
| 