帖子: 132
主題: 31
精華: 0
積分: 167
點名: 0
作業系統: XP
軟體版本: Office 2007
閱讀權限: 20
性別: 男
來自: Taipei
註冊時間: 2011-4-14
最後登錄: 2024-2-28

2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章

1^# 跳轉到 » 正序看帖

字體大小: tT

發表於 2018-10-8 15:01 | 只看該作者

使用VBA抓取網頁資料，大約不到200頁就會當掉，求解

各位大大，小弟我目前遇到一個自己能力無法解出的問題，還望各位大大知道怎麼解決的告知小弟，感謝您。
目前要抓取某家公司放在網路上的零件資料，大約4萬多頁，只要跑大約200左右就會當機，不知道是什麼問題，小弟有放上程式，還請各位大大協助，感謝您。

抓網頁資料程式_W.zip (101.26 KB)

程式檔案

樓主熱帖

clio

mark15jill

　暱稱: 隨風飄蕩的羽毛
　頭銜: [御用]潛水艇

高中生 Rank: 3 Rank: 3

帖子: 852
主題: 79
精華: 0
積分: 918
點名: 0
作業系統: Windows 7 , XP
軟體版本: Office 2007, Office 2003,Office 2010,YoZo Office
閱讀權限: 50
性別: 男
來自: 宇宙
註冊時間: 2011-4-8
最後登錄: 2024-2-21

10^#

發表於 2018-12-30 10:35 | 只看該作者

回復 clio
檔案瘦身
QueryTable ,Name太多檔案會虛胖,你一直的存檔動作,會喘死.
GBKEE 發表於 2018-10-9 12:55

這個比喻真好... 編寫程式時很多都只在意速度確連不用丟進迴圈的也丟進去導致一個固定值被執行N次 ....

  多做多想多學習，少看少錯少迷途

  多做=多多練習，多多編寫。
  多想=想想為什麼人家程式要那樣寫，如果換成自己，又會怎寫。
  多學習=學習人家的發問並解答，學習人家的寫法

  少看=只看不做也枉然

TOP

clio

中學生 Rank: 2

帖子: 132
主題: 31
精華: 0
積分: 167
點名: 0
作業系統: XP
軟體版本: Office 2007
閱讀權限: 20
性別: 男
來自: Taipei
註冊時間: 2011-4-14
最後登錄: 2024-2-28

2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章

9^#

發表於 2018-10-9 13:12 | 只看該作者

回復 8# GBKEE
了解了，感謝GBKEE，所以把所有的QueryTable刪掉，只留下一個，並利用迴圈改變q的connection值，就不會讓QueryTable的數量一直增加，這樣也不會像我原來的程式一樣，因為QueryTable超過一定的數量，造成當掉，這樣我就全理解了，感謝您的耐心解說

clio

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

8^#

發表於 2018-10-9 12:55 | 只看該作者

本帖最後由 GBKEE 於 2018-10-9 12:56 編輯

回復 7# clio
檔案瘦身
QueryTable ,Name太多檔案會虛胖,你一直的存檔動作,會喘死.

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

TOP

clio

中學生 Rank: 2

帖子: 132
主題: 31
精華: 0
積分: 167
點名: 0
作業系統: XP
軟體版本: Office 2007
閱讀權限: 20
性別: 男
來自: Taipei
註冊時間: 2011-4-14
最後登錄: 2024-2-28

2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章

7^#

發表於 2018-10-9 10:54 | 只看該作者

回復 4# GBKEE
感謝GBKEE,
拜讀了您的程式，我大約知道我卡在那個地方了，而且妳的撰寫方式，讓我受用很多，太感謝您了
我大約知道該該表單的QueryTables太多了，有五百多個，難怪會卡住，所以我了解要把QueryTales砍掉的原因了
但是為什麼會有這樣多的Names，而且把這些Names砍掉的好處是，什麼，這點我不太清楚，能否請GBKEE幫我解說一下呢？
感謝您

clio

TOP

clio

中學生 Rank: 2

帖子: 132
主題: 31
精華: 0
積分: 167
點名: 0
作業系統: XP
軟體版本: Office 2007
閱讀權限: 20
性別: 男
來自: Taipei
註冊時間: 2011-4-14
最後登錄: 2024-2-28

2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章

6^#

發表於 2018-10-9 09:14 | 只看該作者

回復 5# joey0415
Hi Joey0415,
能否也把您的完整程式，讓我來研究一下，看是差別在那邊，為什麼我的會當掉，若是方便的話，感謝您。

clio

TOP

joey0415

　暱稱: joey0415

中學生 Rank: 2

帖子: 361
主題: 57
精華: 0
積分: 426
點名: 0
作業系統: win7
軟體版本: 2003,2010
閱讀權限: 20
性別: 男
註冊時間: 2010-5-13
最後登錄: 2022-12-8

5^#

發表於 2018-10-8 20:59 | 只看該作者

回復 3# clio

我也測試過哦！三分鐘下載300頁沒有問題
很順

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

4^#

發表於 2018-10-8 19:10 | 只看該作者

回復 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

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

TOP

clio

中學生 Rank: 2

帖子: 132
主題: 31
精華: 0
積分: 167
點名: 0
作業系統: XP
軟體版本: Office 2007
閱讀權限: 20
性別: 男
來自: Taipei
註冊時間: 2011-4-14
最後登錄: 2024-2-28

2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章

3^#

發表於 2018-10-8 18:24 | 只看該作者

回復 2# joey0415
HI Joey0415,
測試過，這樣更早就當掉了說…

clio

TOP

joey0415

　暱稱: joey0415

中學生 Rank: 2

帖子: 361
主題: 57
精華: 0
積分: 426
點名: 0
作業系統: win7
軟體版本: 2003,2010
閱讀權限: 20
性別: 男
註冊時間: 2010-5-13
最後登錄: 2022-12-8

2^#

發表於 2018-10-8 16:26 | 只看該作者

回復 1# clio

Sub 巨集1()
Cells.Clear
SURL = "URL;http://www.passivecomponent.com/asp/search_chip.aspx?page2"
Set myQT = ActiveSheet.QueryTables.Add(Connection:=SURL, Destination:=Range("$A$1"))
With myQT
      .WebFormatting = xlWebFormattingNone
      .Refresh BackgroundQuery:=False
      .Delete
End With

SET MYQT=NOTHING
End Sub

頁數自己換

TOP