麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 如何找出網站原始檔網址 [打印本頁]

作者: blue2263 時間: 2013-12-26 21:48 標題: 如何找出網站原始檔網址

我想用web查詢,下載公開觀測站的資料,到excel,要如何找出原始檔網址

我想找的網址如下:董監事持股餘額明細資料內的歷史資料
http://mops.twse.com.tw/mops/web/stapap1?

還請逹人大大幫忙,感恩謝謝

作者: GBKEE 時間: 2013-12-27 16:07

回復 1# blue2263
試試看

Option Explicit
Sub 公開資訊網頁()
Dim A As Object, E As Object
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 = "102" '年度
'.document.getElementById("season").Value = "01" '綜合損益表:第1季(季別)
.document.getElementById("month").Value = "08" '董監事持股餘額明細資料:月份
End If
'********************************************************************
For Each A In .document.getelementSbyTAGNAME("INPUT")
If A.Name = "co_id" Then A.Value = "2303" '股票代號
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
With ActiveSheet
.Cells.Clear
.Cells(1).Select
.PasteSpecial Format:="HTML"
End With
End If
Next
.Quit '關閉 IE
End With
End Sub

複製代碼

作者: stillfish00 時間: 2013-12-27 20:21

回復 1# blue2263

http://mops.twse.com.tw/mops/web/ajax_stapap1?encodeURIComponent=1&step=1&firstin=1&off=1&queryName=co_id&TYPEK=all&isnew=false&co_id=1101&year=102&month=11

複製代碼

co_id=1101&year=102&month=11

作者: blue2263 時間: 2013-12-27 22:36

感謝G大回復,G大真是神人,原來還有這種直接打開IE下載資料的作法
請教G大,比如A1儲存格輸入股票代碼,A2年度,A3月份,我要用儲存格來更改,我要下載的資料
,巨集要如何更改,麻煩你了感恩
另外請教G大,有沒這方面推薦的書籍或教程,VBA我還是個超級新手

作者: blue2263 時間: 2013-12-27 22:40

謝謝stillfish00 大回復
請教原始檔網址是如何找出來的,可以教我嗎,謝謝

作者: GBKEE 時間: 2013-12-28 19:05

回復 4# blue2263

A1儲存格輸入股票代碼,A2年度,A3月份

程式碼中有註解股票代碼 ,年度,月份
將那些=字串取代為 A1,A2,A3

作者: blue2263 時間: 2013-12-29 07:22

G大你好
我將 If A.Name = "co_id" Then A.Value = "2330" '股票代號
改為 If A.Name = "co_id" Then A.Value = A1 '股票代號
出現編譯錯誤,是我那邊改錯了,請幫我看一下謝謝

作者: GBKEE 時間: 2013-12-29 15:02

回復 7# blue2263

A1是工作表上的位置, VBA 語法 Range("A1")

If A.Name = "co_id" Then A.Value =Range("A1") '股票代號

複製代碼

作者: blue2263 時間: 2013-12-29 22:52

謝謝g大解答

作者: blue2263 時間: 2014-1-1 15:27

可否請G大, 再幫我下列網址,資料用VBA方式下載,程式碼要如何寫
http://www.tdcc.com.tw/smWeb/QryStock.jsp
感恩謝謝!

作者: GBKEE 時間: 2014-1-1 16:37

回復 10# blue2263
參考這裡

作者: blue2263 時間: 2014-1-2 00:04

感謝G大,提供路徑,我找到原始檔網址位置

作者: blue2263 時間: 2014-1-2 00:13

可否請G大幫我看一下,以下程式碼,我逐步執行(F8)沒問題,但是改用執行巨集時,都會停在
(Sheets("匯總").Select )出現程式碼的執行己被中斷錯誤訊息,不知那個地方有問題

Sub Macro()
'
' Macro Macro
' 報表整合
'

'
  Application.ScreenUpdating = False '讓視窗不跟隨更新變動
  If ActiveCell.Value <> Empty Then
   Application.CutCopyMode = False
Selection.Copy

            Sheets("原始表").Select
            Range("B2").Select

            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                  :=False, Transpose:=False '貼上

                  On Error GoTo 101 ' '新增條件開始101
            Sheets("原始表").Range("E7").QueryTable.Refresh BackgroundQuery:=False
            Sheets("匯總").Select
            Range("A2:K21").Select
            Selection.Copy
            Range("A1").Select
            Selection.End(xlDown).Select '到最底資料列
            ActiveCell.Offset(1, 0).Range("A1").Select '下一列
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                  :=False, Transpose:=False '貼上值

101
            Sheets("巨集工作表").Select
            ActiveCell.Offset(1, 0).Range("A1").Select
Call Macro
   End If
   End Sub

作者: blue2263 時間: 2014-1-2 07:55

本帖最後由 blue2263 於 2014-1-2 07:57 編輯

G大你好
我後來將程式碼做了下列的更改,就可執行沒問題了
(Application.ScreenUpdating = False '讓視窗不跟隨更新變動) 去除此行
Application.Wait (Now + TimeValue("0:00:001")) '新增此行
Sheets("匯總").Select

但是為了執行上更快速
我將(讓視窗不跟隨更新變動),此行程式碼加入時,也一樣會有錯誤
請教程式碼要如何更比較好?
麻煩你了感恩謝謝

作者: GBKEE 時間: 2014-1-2 08:27

回復 14# blue2263

我將(讓視窗不跟隨更新變動),此行程式碼加入時,也一樣會有錯誤

你沒附檔,莫宰羊.

作者: blue2263 時間: 2014-1-2 19:05

[attach]17185[/attach]
請g大查收圖檔,感恩謝謝

作者: GBKEE 時間: 2014-1-3 08:31

回復 16# blue2263

Sub Macro()
Application.ScreenUpdating = False '讓視窗不跟隨更新變動
If ActiveCell.Value <> Empty Then
Application.CutCopyMode = False
Selection.Copy
Sheets("原始表").Select
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False '貼上
On Error GoTo 101 ' '新增條件開始101
'*********************************************************************
'ActiveCell.Value應是這Sheets("原始表").Range("E7")QueryTable的股票代號
'但Sheets("巨集工作表").Select
'ActiveCell.Offset(1, 0).Range("A1").Select <-沒有股票代號
'Web的更新會錯誤一直的 GoTo 101
Sheets("原始表").Range("E7").QueryTable.Refresh BackgroundQuery:=True
'*********************************************************************
'Application.Wait (Now + TimeValue("0:00:02"))
Sheets("匯總").Select
Range("A2:K21").Select
Selection.Copy
Range("A1").Select
Selection.End(xlDown).Select '到最底資料列
ActiveCell.Offset(1, 0).Range("A1").Select '下一列
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False '貼上值
101
Sheets("代碼").Select '修改這裡試試看
'Sheets("巨集工作表").Select
ActiveCell.Offset(1, 0).Range("A1").Select
Call Macro
End If
End Sub

複製代碼

作者: blue2263 時間: 2014-1-3 21:07

g大你好,
是將'Sheets("巨集工作表").Select
改為Sheets("代碼").Select 嗎?
我巨集開始執行,是由(巨集工作表)開始的,
改為由代碼開始執行一樣會有,當掉無回應的問題
不好意思還請再幫我看一下謝謝

作者: GBKEE 時間: 2014-1-4 08:56

本帖最後由 GBKEE 於 2014-1-4 08:57 編輯

回復 18# blue2263

Option Explicit
Sub Ex()
Dim Rng(1 To 2) As Range
On Error Resume Next '執行程式碼如有錯誤繼續執行下一個程式碼: 股票Web有錯誤時
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").QueryTable.Refresh BackgroundQuery:=False
Set Rng(2) = .Range("A10:K29") '你要的原始資料
End With
If Err = 0 Then
Application.StatusBar = Rng(1) & " 匯入中"
With Sheets("匯總").Range("A1").End(xlDown).Offset(1)
.Range("A1:K20").Value = Sheets("匯總").Range("A2:K21").Value
Rng(1).Parent.Hyperlinks.Add Anchor:=Rng(1).Offset(, 2), Address:="", SubAddress:=.Address(, , , 1), TextToDisplay:=.Parent.Name & "!" & .Address(0, 0)
'重新設定超連結
End With
'************'用此程式碼:配合需清除舊有資料 ******************************
'With Sheets("匯總").Range("A" & Sheets("匯總").Rows.Count).End(xlUp).Offset(1)
' .Resize(Rng(2).Rows.Count, Rng(2).Columns.Count) = Rng(2).Value
' Rng(1).Parent.Hyperlinks.Add Anchor:=Rng(1).Offset(, 2), Address:="", SubAddress:=.Address(, , , 1), TextToDisplay:=.Parent.Name & "!" & .Address(0, 0)
'End With
'********************************************
Else
With Rng(1).Offset(, 2)
.Hyperlinks.Delete '股票Web錯誤:刪除超連結
.Value = ""
End With
Err.Clear
End If
Set Rng(1) = Rng(1).Offset(1)
Loop
Application.StatusBar = " 工作完成 !!"
End Sub

複製代碼

作者: blue2263 時間: 2014-1-4 13:11

本帖最後由 blue2263 於 2014-1-4 13:12 編輯

感謝G大的熱心幫忙
G大我發現有個奇怪現象,
當我在執行巨集當中如果想要,暫停巨集,按下組鍵CTRL+ESC+PAUSE,停止巨集後,->然後再次執行巨集會變成無法自動執行巨集,
都會執行一下後中斷,然後出現,(程式碼的執行己被中斷),必須重開電腦,這現象才會消除
以上測試用G大的程式碼或自己的都會是相同情況,

作者: blue2263 時間: 2014-1-4 13:20

本帖最後由 blue2263 於 2014-1-4 13:22 編輯

我發現G大程式碼,執行上快很多,不好意恩,我是VBA幼稚園生,
執行速度要快,重點是什麼,要改什麼地方?
謝謝G大熱心幫忙

作者: GBKEE 時間: 2014-1-4 15:10

回復 21# blue2263
20# 按下組鍵CTRL+ESC+PAUSE,停止巨集後,->然後再次執行巨集會變成無法自動執行巨集,,你的Excel有問題.

迴圈的程式少用 Copy(佔用資源,減緩速度),Select(切換位置,佔用時間),多參考範例,多練習,會進步的.

作者: blue2263 時間: 2014-1-4 20:09

本帖最後由 blue2263 於 2014-1-4 20:11 編輯

請教G大
關於G大程式碼
此句Set Rng(1) = .Range("b2")
我如要將 .Range("b2"),改為,所選儲存格
程式碼要如何寫

PS:所選儲存格=ActiveCell.Offset(0, 0).Range("A1").Select

作者: GBKEE 時間: 2014-1-5 07:05

本帖最後由 GBKEE 於 2014-1-5 07:10 編輯

回復 23# blue2263
你要多了解VBA的方法.屬性.函數

ActiveCell.Offset(0, 0).Range("A1").Select
分解: .Offset(0, 0) :原位置
.Offset(0, 0).Range("A1") :原位置的A1
那不就一樣是 ActiveCell

10# 39行程式碼: 原位置下移一列位置

Set Rng(1) = Rng(1).Offset(1)

複製代碼

作者: blue2263 時間: 2014-1-5 10:40

了解了,感謝G大,幫忙及指教

作者: xcvk5631 時間: 2014-1-9 18:19

我落伍了～～（拭淚）

作者: philicat 時間: 2014-1-14 09:56

厲害~感謝分享

作者: yuch8663 時間: 2014-1-14 13:17

厲害~感謝分享

作者: pollllopkimo 時間: 2014-1-25 21:30

回復 2# GBKEE

請教g大
若股票代號改在b1儲存格這沒有問題
年份要改成在c1儲存格~改出來都失敗
月份要改成在d1儲存格~改出來都失敗
以及最後的
下載產生資料結果要放在b2儲存格而不要放在a1儲存格

還請多多幫忙謝謝

作者: GBKEE 時間: 2014-1-26 08:49

回復 29# pollllopkimo

上傳檔案看看

作者: pollllopkimo 時間: 2014-1-26 15:14

回復 30# GBKEE

請參考附件
麻煩G大了謝謝

作者: GBKEE 時間: 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

複製代碼

作者: pollllopkimo 時間: 2014-1-26 20:40

回復 32# GBKEE

先謝謝g大
目前發現一個問題例如當抓股票代號2886時候
會把網頁上的圖片[attach]17378[/attach]也一併抓下來
再抓第二次時候該圖片會殘留
有辦法抓第二次時刪除或是第一次只抓文字,表格嘛?
再次麻煩g大謝謝

作者: blue2263 時間: 2014-2-5 22:50

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

作者: GBKEE 時間: 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

複製代碼

作者: blue2263 時間: 2014-2-6 12:22

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

作者: GBKEE 時間: 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

複製代碼

作者: blue2263 時間: 2014-2-6 19:03

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

作者: GBKEE 時間: 2014-2-6 20:48

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

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

[attach]17444[/attach]

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

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

複製代碼

作者: blue2263 時間: 2014-2-7 07:59

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

作者: GBKEE 時間: 2014-2-7 08:16

回復 40# blue2263
直接讀取資料,比拐彎(函數計算)讀取資料當然是快的

在有刪工作表的檔案,用#39程式碼, 下載10個代碼,花了6秒,資料正確
在沒有刪工作表的檔案,用#39程式碼, 下載10個代碼,花了3分9秒,資料正確

在沒有刪工作表的檔案(函數太多),執行原來程式(程式執行迴圈一次,活頁簿的函數重算尚未完成)故得到資料不正確

作者: blue2263 時間: 2014-2-7 21:06

了解!感謝G大幫忙解答

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)