如何找出網站原始檔網址 - Excel程式區

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

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

32^#

發表於 2014-1-26 18:02 | 只看該作者

本帖最後由 GBKEE 於 2014-1-28 07:00 編輯

回復 31# pollllopkimo

Option Explicit
Sub 公開資訊網頁()
Dim A As Object, E As Object, Sh As Worksheet
Set Sh = Sheets("sheet1") '物件: 指定工作表
Sh.Activate
With CreateObject("InternetExplorer.Application")
'.Visible = True
' .Navigate "http://mops.twse.com.tw/mops/web/t164sb04" '網址:綜合損益表
.Navigate "http://mops.twse.com.tw/mops/web/stapap1" '網址:董監事持股餘額明細資
Do While .ReadyState <> 4 Or .Busy: DoEvents: Loop
.document.getElementById("isnew").Value = "false" '選擇: 歷史資料
'註解上一行程式碼為 -> 選擇: 最新資料,不會執行 If 內程式碼
If .document.getElementById("isnew").Value = "false" Then
.document.getElementById("isnew").FireEvent ("onchange")
.document.getElementById("year").Value = Sh.Range("C1") '年度
'.document.getElementById("season").Value = "01" '綜合損益表:第1季(季別)
.document.getElementById("month").Value = Format(Sh.Range("D1"), "00") '董監事持股餘額明細資料:月份
End If
'********************************************************************
For Each A In .document.getelementSbyTAGNAME("INPUT")
If A.Name = "co_id" Then A.Value = Sh.Range("b1") '股票代號
If A.Value = " 搜尋 " Then A.Click '按下搜尋
Next
Do While .ReadyState <> 4 Or .Busy: DoEvents: Loop
For Each E In .document.ALL.TAGS("div")
If E.ID = "table01" Then
.document.body.innerHTML = E.outerHTML
.ExecWB 17, 2 ' Select All
.ExecWB 12, 2 ' Copy selection
Do While .ReadyState <> 4 Or .Busy: DoEvents: Loop
With Sh
.UsedRange.Offset(4).Clear
.Range("B5").Select
.PasteSpecial Format:="HTML"
.Range("B5").Select
If .Shapes.Count > 0 Then '有圖片
.Shapes.SelectAll
Selection.Delete
End If
End With
End If
Next
.Quit '關閉 IE
End With
End Sub

複製代碼

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

pollllopkimo

小學生 Rank: 1

帖子: 3
主題: 0
精華: 0
積分: 4
點名: 0
作業系統: xp
軟體版本: 2003
閱讀權限: 10
註冊時間: 2014-1-25
最後登錄: 2014-1-29

論壇贊助勳章

33^#

發表於 2014-1-26 20:40 | 只看該作者

[版主管理留言]

GBKEE(2014/2/6 08:02): 32#的程式碼已更新

回復 32# GBKEE

先謝謝g大
目前發現一個問題例如當抓股票代號2886時候
會把網頁上的圖片圖片.JPG

也一併抓下來
再抓第二次時候該圖片會殘留
有辦法抓第二次時刪除或是第一次只抓文字,表格嘛?
再次麻煩g大謝謝

帖子: 150
主題: 40
精華: 0
積分: 215
點名: 0
作業系統: windows xp
軟體版本: sp3
閱讀權限: 20
註冊時間: 2013-7-15
最後登錄: 2025-5-26

34^#

發表於 2014-2-5 22:50 | 只看該作者

G大你好,之前程式,為了需求,做了一些修改,有些問題,想請G大麻煩幫我看一下
1.程式會無法自動執行,會中斷?
2.按F8逐行執行沒有問題,但發現執行下載後的資料與原始資料不同?

檔A.rar (74.39 KB)

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

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

35^#

發表於 2014-2-6 08:18 | 只看該作者

回復 34# blue2263
按F8逐行執行是哪一個程序

'****** 附檔沒這工作表
With Sheets("巨集工作表")
Set Rng(1) = .Range("B2")
.Activate
End With
'Sheets("匯總").UsedRange.Offset(1).Clear '用此程式碼" 如需清除舊有資料
Do While Rng(1) <> ""
Rng(1).Activate
With Sheets("原始表")
.Range("B2") = Rng(1)
'**** .Range("E7") 沒有Web **********
.Range("E7").QueryTable.Refresh BackgroundQuery:=False

複製代碼

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

帖子: 150
主題: 40
精華: 0
積分: 215
點名: 0
作業系統: windows xp
軟體版本: sp3
閱讀權限: 20
註冊時間: 2013-7-15
最後登錄: 2025-5-26

36^#

發表於 2014-2-6 12:22 | 只看該作者

G大,不好意思我指的問題程序是,報表整合1-new
程式會中斷及按F8執行,下載資料拿錯誤,都是此程序
謝謝G大

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

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

37^#

發表於 2014-2-6 13:44 | 只看該作者

本帖最後由 GBKEE 於 2014-2-6 13:46 編輯

回復 36# blue2263

Sub Macro()
' 報表整合1-new
Dim Rng As Range
On Error GoTo 101 ' 'web 查無到下一個代碼
Set Rng = Sheets("代碼").[a2]
Do While Rng(1) <> "" '無代碼中斷
With Sheets("原始表")
.Range("a6") = Rng
.Range("az7").QueryTable.Refresh BackgroundQuery:=False
End With
With Sheets("匯總").Range("A1").End(xlDown).Offset(1) '選擇工作表,到最底行
.Range("A1:aw1").Value = Sheets("原始表").Range("A6:aw6").Value
End With
101
Set Rng = Rng.Offset(1) '下一個代碼
Loop
End Sub

複製代碼

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

帖子: 150
主題: 40
精華: 0
積分: 215
點名: 0
作業系統: windows xp
軟體版本: sp3
閱讀權限: 20
註冊時間: 2013-7-15
最後登錄: 2025-5-26

38^#

發表於 2014-2-6 19:03 | 只看該作者

感謝G大熱心幫忙,問題1,己可正常執行了
另請教G大,因我這個檔案,內有很多函數,所以造成資料更新會變的很慢
所以執行巨集時會造成資料錯誤,如下圖
請教G大是否有程式碼,可解決此問題,還是只能將檔案分開為兩個(下載資料用,及分析用)

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

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

39^#

發表於 2014-2-6 20:48 | 只看該作者

本帖最後由 GBKEE 於 2014-2-6 20:55 編輯

回復 38# blue2263
內有很多函數,所以造成資料更新會變的很慢,應該不是如此.
是否活頁簿的計算是手動,要改成自動

下列程式碼,工作表可不用函數算.

Option Explicit
Sub Macro()
' 報表整合1-new
Dim Rng As Range, Ar(1 To 3)
On Error GoTo 101 ' 'web 查無到下一個代碼
Set Rng = Sheets("代碼").[a2]
Do While Rng <> "" '無代碼中斷
With Sheets("原始表")
.Range("a6") = Rng
.Range("az7").QueryTable.Refresh BackgroundQuery:=False
With .Range("BB12:BB27")
Ar(1) = Application.Transpose(.Cells) '人數
Ar(2) = Application.Transpose(.Offset(, 1)) '股數
Ar(3) = Application.Transpose(.Offset(, 2)) '佔集保庫存數比例 (%)
End With
End With
With Sheets("匯總").Range("A1").End(xlDown).Offset(1) '選擇工作表,到最底行
.Cells(1) = Rng
.Cells(1, 2) = Rng.Offset(, 1)
.Cells(1, "C").Resize(, UBound(Ar(1))) = Ar(1)
.Cells(1, "S").Resize(, UBound(Ar(1))) = Ar(2)
.Cells(1, "AI").Resize(, UBound(Ar(1))) = Ar(3)
.Cells(1, "AX") = ""
'.Range("A1:aw1").Value = Sheets("原始表").Range("A6:aw6").Value
End With
101
Set Rng = Rng.Offset(1) '下一個代碼
Loop
End Sub

複製代碼

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

帖子: 150
主題: 40
精華: 0
積分: 215
點名: 0
作業系統: windows xp
軟體版本: sp3
閱讀權限: 20
註冊時間: 2013-7-15
最後登錄: 2025-5-26

40^#

發表於 2014-2-7 07:59 | 只看該作者

謝謝G大幫忙
回覆G大,我的設定是自動的沒錯,
用#39程式碼下載資料內容就正確了
我提供的檔案,有刪掉一些有函數工作表,所以跑起來會很慢
我做了一些測試
在有刪工作表的檔案,用#39程式碼, 下載10個代碼,花了6秒,資料正確
在沒有刪工作表的檔案,用#39程式碼, 下載10個代碼,花了3分9秒,資料正確
在沒有刪工作表的檔案,用#36程式碼,下載10個代碼,花了1分30秒,資料左天測試,是錯誤的(#38情形),今天又測試一次,資料又變回正確了??不知道是什麼問題?
請教G大,理論上是否用#39方法,資料上較不會有問題,
為了下載資料的速度,盡量檔案內也不要太多函數