(不定期更新)使用VBA解決 excel web 查詢無法匯入、匯入太慢的股市資料

snare

2598分

樓主

snare

個人積分：2598分

文章編號：67298548

keeptry wrote:
269樓的方式
要先取得2個參數 VIEWSTATE+EVENTVALIDATION
再啟動網頁上的java程式(假按鈕)
所以也可以運用在這邊下載 .XLS 檔案了?...(恕刪)

不好意思，這邊訂正一下269樓的範例不能用在Goodinfo!這個網站

台灣股市資訊網，那2個按鍵是“真按鈕”
因為在網頁原始碼中是用input type='button'
按下後再連結到java
onclick="export2xls(divDetail[removed]... ...

產生 blob 格式這種特殊的url，時效只有一次，每次url都不一樣

但是在Goodinfo!這個網站，沒必要花心思去取得blob url
因為產生的blob url 是本地端的，資料其實不在網路上
資料是在電腦記憶體，沒有本地端的資料也不會產生blob url
所以直接抓網頁原始碼的資料就好，程式比較簡單

這裡先簡單解釋一下 get post 的差別

HTTP Get 通常用在一般網址(真實網址)的使用
在程式碼中只要網址+send，網站就會回傳資料

例如：(yahoo中鋼股價)
https://tw.stock.yahoo.com/q/q?s=2002

HTTP POST 通常用在要跟網站拿資料
像是登入、或是像股市資料，要先選擇日期、報表、種類
特別是在輸入資料、選擇日期、報表、種類時，網址不會有任何的改變
或是資料都顯示在網頁上了，但按下檢視原始碼時，確看不到任何資料的網站

所以在程式碼中，需要網址 + send + 變數，才能取得資料

不過，要用get post 不一定，要看網站設計，有的首頁是get，第2頁又變成post
要看是什麼就要用f12開發者工具(或其它像是fiddler等第3方工具)去檢查

keeptry wrote:
149樓的方式去是抓各種列表，這個可以抓得起來沒問題
但如果抓基本分析的現金流量...(恕刪)

您的2個副程式我看過了，除了排版之外，沒什麼問題，都可以正常下載
149樓只是報表不同、變數不同、網址不同，但下載方式是一樣的
有空我再做個範例

keeptry

1分

292樓

keeptry

個人積分：1分

文章編號：67299343

Snare 大大說的範例是指真按鈕下載 .xls 的範例嗎?
先搬個沙發等著學習

我剛剛又試了一下
我想我的 Get 方式不能用也許不是程式碼的問題

我直接完全 copy 21樓的程式碼，放在模組後執行
用的也是 Get 方法
一樣是跑到 .sned 就出現 error 了
也許我得換個電腦或環境再試看看

(換台電腦也是完全一樣的情況，不知道為什麼了 orz

)

排版的問題我後面可以再自行處理，只要能抓的到資料就沒問題囉
謝謝大大的回覆

snare

2598分

樓主

snare

個人積分：2598分

文章編號：67310618

keeptry wrote:
範例是指真按鈕下載 .xls 的範例嗎?
...(恕刪)

不是，我在291樓解釋過了(blob url)

keeptry wrote:
我直接完全 copy 21樓的程式碼，放在模組後執行
用的也是 Get 方法
一樣是跑到 .sned 就出現 error 了
也許我得換個電腦或環境再試看看
...(恕刪)

一字未改

keeptry wrote:
(換台電腦也是完全一樣的情況，不知道為什麼了orz)...(恕刪)

您290樓檔案，也可以正常執行

也許是您的網路問題，可能是設定了什麼奇怪的dns、proxy server

這種簡單的程式碼沒有相容性問題，
excel 2003 之後的版本(32、64位元)都可以正常執行，更早的版本沒測試過

snare

2598分

樓主

snare

個人積分：2598分

文章編號：67311232

Goodinfo!台灣股市資訊網，現金流量(六大報表)，免排版簡易下載範例

這個網頁上的資料有很多的合併儲存格
如果使用.all.tags("table")方式抓資料會造成資料位置錯位、文字無法對齊…等
需要另外寫程式碼修正

但是在現金流量(六大報表)這個網頁裡
有2個產生 blob url格式的下載按鈕(請參考291樓說明)
所以可以利用記憶體中整理好的資料來貼上excel儲存格，省去排版問題，還可以減少程式碼

保留原始格式

只保留一個標題

'===================================================
'程式碼放在工作表1，需先建一個activex 命令按鈕
'===================================================
Private Sub CommandButton1_Click()

Dim stockID As String, Report1 As String, Report2 As String
On Error Resume Next
With Sheets("工作表1")
.Select

If .OLEObjects("CommandButton1").Object.Caption = "輸入股票代碼" Then
.ListBoxes("list_0").Delete
.Cells.Clear

stockID = InputBox("請輸入四碼股票代號" & vbNewLine & "(輸入後，也可以直接修改C3儲存格)", , "2002")
If stockID = "" Then Exit Sub

.Cells(2, 3) = "股票代碼": .Cells(3, 3) = stockID
Call AddListBox
.OLEObjects("CommandButton1").Object.Caption = "按我下載"
Else
.OLEObjects("CommandButton1").Object.Caption = "輸入股票代碼"
Report1 = Trim(Split(.ListBoxes("list_0").List(.ListBoxes("list_0")), ",")(0))
Report2 = Split(.ListBoxes("list_0").List(.ListBoxes("list_0")), ",")(1)
.ListBoxes("list_0").Delete
Call getgoodinfo(Report1, Report2)
End If

End With

End Sub
'===================================================
'以下程式碼放在模組裡
'===================================================

Sub getgoodinfo(Report1 As String, Report2 As String)

ttt = Timer

Dim HTMLsourcecode, Table, Clipboard As Object, stockID As String, URL As String, URL_a As String
Set HTMLsourcecode = CreateObject("htmlfile")
Set Clipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
stockID = Sheets("工作表1").Cells(3, 3)

URL = "https://goodinfo.tw/StockInfo/StockCashFlow.asp?STOCK_ID=" & stockID & "&RPT_CAT=" & Report2
URL_a = "https://goodinfo.tw/StockInfo/StockCashFlow.asp?STOCK_ID=" & stockID

With CreateObject("WinHttp.WinHttpRequest.5.1")
.Open "POST", URL, False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.setRequestHeader "Referer", URL_a
.setRequestHeader "Cache-Control", "no-cache"
.setRequestHeader "Pragma", "no-cache"
.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
.send

HTMLsourcecode.body.innerhtml = convertraw(.ResponseBody)
Set Table = HTMLsourcecode.getelementbyid("txtFinDetailData")
If Table.innertext = "查無資料" Then
Sheets("工作表1").Cells(2, 3) = "查無資料"
Exit Sub
End If

With Clipboard
.SetText Table.innerhtml
.PutInClipboard
End With

With Sheets("工作表1")
.Select
.Cells.Clear
.Cells(1, 1).Select
.PasteSpecial NoHTMLFormatting:=True
.Columns.AutoFit
.Cells(1, 1) = stockID & Split(HTMLsourcecode.all.tags("table")(13).innertext, " ")(1) & "(" & Report1 & ")"
.Cells(2, 1).Select
MsgBox .Cells(1, 1) & "下載時間" & Round(Timer - ttt, 2) & "秒", vbOKOnly, "Report"
End With
End With

'Call DelTitle '如果只想保留一個標題，請把這行啟用

Set HTMLsourcecode = Nothing
Set Table = Nothing
Set Clipboard = Nothing

End Sub
Function convertraw(rawdata)

Dim rawstr
Set rawstr = CreateObject("adodb.stream")

With rawstr
.Type = 1
.Mode = 3
.Open
.Write rawdata
.Position = 0
.Type = 2
.Charset = "utf-8"
convertraw = .ReadText
.Close
End With

Set rawstr = Nothing

End Function

Sub AddListBox()

With Sheets("工作表1")
Set list_0 = .ListBoxes.Add(.Range("b7").Left + 5, .Range("b7").Top, 100, 100)
With list_0
.Name = "list_0"
list_0.List = Array("合併季報" & Space(30) & ",M_QUAR", "合併累計季報" & Space(30) & ",M_QUAR_ACC", "合併年報" & Space(30) & ",M_YEAR", "非合併季報" & Space(30) & ",QUAR", "非合併累計季報" & Space(30) & ",QUAR_ACC", "非合併年報" & Space(30) & ",YEAR")
.Selected(1) = True
End With
End With

End Sub

Sub DelTitle()

With Sheets("工作表1")
For i = .Range("a1").CurrentRegion.Rows.Count To 6 Step -1
If .Cells(i, 1) = "年度" Or .Cells(i, 1) = "季度" Then
.Rows(i & ":" & i + 3).Delete Shift:=xlUp
End If
Next i
.Cells(2, 1).Select
End With

End Sub

'===================================================

附加壓縮檔: 201802/mobile01-c03619d1ad4587e58bca5f20f0d1b622.zip

bioleon69

63分

295樓

bioleon69

個人積分：63分

文章編號：67311705

snare wrote:
預告：Goodinf...(恕刪)

免排版?

期待師傅更新

感謝師兄弟持續追蹤此樓

把師傅問倒!

keeptry

1分

296樓

keeptry

個人積分：1分

文章編號：67324376

Snare 大大

如果是網路的問題導致無法抓值
那我再自己試試不同的網路環境跟電腦看看

現金流量的新的程式碼我先吸收一下
謝謝師傅

樓上師兄
感覺上我們要抓的東西所需要接觸到的領域
師傅是問不倒的

bioleon69

63分

297樓

bioleon69

個人積分：63分

文章編號：67331285

恩,師傅真的挺強的
應該是專門在寫程式
就是有點冷酷冷酷
哈!

snare

2598分

樓主

snare

個人積分：2598分

文章編號：67355049

(因網站改版，此範例失效，請改參考328樓)
臺灣集中保管結算所(保戶股權分散表查詢)
http://www.tdcc.com.tw/smWeb/QryStock.jsp

這個範例，其實我在190樓就寫過了，當時是回答問題寫的
在244樓，也有一篇“偽”多工處理的範例
不過“偽”多工這篇，主要目地是讓大家了解excel可以多開
是因為有趣才這樣寫的 sorry

不建議用在同一個網站，加速太快會被擋ip(用在不同的網站就很適合)

那為什麼又發一篇呢?因為看到這篇文章

裡面的這個表，選2個日期來比較，雖然我用不到，但好像很好玩
再加上我有不少張宏碁的股票

，所以就把這個功能寫成範例

'=====================================
'工作表1要建立一個表單控製項的按鈕
'程式碼放在 thisworkbook
'=====================================
Private Sub Workbook_Open()
Call AddDateListBox
End Sub

'=====================================
'以下程式碼放在模組
'=====================================
Sub acer()

Dim SCA_DATE, HTMLsourcecode As Object, stockid As String, stockname As String, r As Integer, url_a As String
Set HTMLsourcecode = CreateObject("htmlfile")

Sheets("工作表1").Columns("C:N").ClearContents
If Sheets("工作表1").Cells(1, 1) = "" Then
stockid = InputBox("請輸入證券代號" & vbNewLine & "(輸入後，也可以直接修改a1儲存格)", , "2353")
If stockid = "" Then Exit Sub
Sheets("工作表1").Cells(1, 1) = stockid
Else
stockid = Sheets("工作表1").Cells(1, 1)
End If

Application.ScreenUpdating = False

ttt = Timer

day1 = Sheets("工作表1").ListBoxes("list_0").List(Sheets("工作表1").ListBoxes("list_0"))
day2 = Sheets("工作表1").ListBoxes("list_1").List(Sheets("工作表1").ListBoxes("list_1"))

For k = 1 To 2
r = 0
retry2:
url_a = "SCA_DATE=" & Choose(k, day1, day2) & "&SqlMethod=StockNo&StockNo=" & stockid & "&StockName=&sub=%ACd%B8%DF"
With CreateObject("WinHttp.WinHttpRequest.5.1")
.Open "POST", "http://www.tdcc.com.tw/smWeb/QryStock.jsp", False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.setRequestHeader "Referer", "http://www.tdcc.com.tw/smWeb/QryStock.jsp"
.send url_a

HTMLsourcecode.body.innerhtml = convertraw(.ResponseBody)
If InStr(HTMLsourcecode.body.innerhtml, "查無資料!") > 0 Then
MsgBox "查無資料!!", vbOKOnly, "Error"
Exit Sub
End If
If InStr(HTMLsourcecode.body.innerhtml, "Your request timed out") > 0 Then
Debug.Print "timeout"
DelayTick (100)
r = r + 1
If r > 5 Then
MsgBox "請稍後再試", vbOKOnly, "Error"
Exit Sub
End If
GoTo retry2
End If

stockname = HTMLsourcecode.all.tags("table")(6).Rows(0).innertext
Set Table = HTMLsourcecode.all.tags("table")(7).Rows

With Sheets("工作表1")
For i = 1 To Table.Length - 1
For j = 0 To Table(i).Cells.Length - 1
.Cells(i + 3, j + 3 + ((k - 1) * 5)) = Table(i).Cells(j).innertext
Next j
Next i
End With

End With
Next k

With Sheets("工作表1")
.Range("c3:n3") = Array("序", "持股", "人數", "股數", "比例%", "序", "持股", "人數", "股數", "比例%", "人數變化", "張數變化")
.Cells(2, 4) = day1
.Cells(2, 9) = day2
.Cells(4, 13).FormulaR1C1 = "=RC[-3]-RC[-8]"
.Cells(4, 14).FormulaR1C1 = "=RC[-3]-RC[-8]"
.Range("M4:N4").AutoFill Destination:=Range("M4:N18"), Type:=xlFillDefault
.Cells.Font.Size = "10"
.Columns.AutoFit
.Columns("A:B").ColumnWidth = 15
.Cells(1, 4) = Split(stockname, "資料日期")(0) ' debug
.Cells(1, 1).Select
End With

Set Table = Nothing
Set HTMLsourcecode = Nothing

Application.ScreenUpdating = True

Debug.Print Timer - ttt

End Sub
Sub AddDateListBox()

Dim SCA_DATE, HTMLsourcecode As Object, Getxml As Object, list_0, list_1, temp(), r As Integer
Set HTMLsourcecode = CreateObject("htmlfile")
Set Getxml = CreateObject("msxml2.xmlhttp")
On Error Resume Next
r = 0
retry1:
With Getxml
.Open "GET", "http://www.tdcc.com.tw/smWeb/QryStock.jsp", False
.send
HTMLsourcecode.body.innerhtml = convertraw(.ResponseBody)
Set SCA_DATE = HTMLsourcecode.getElementbyid("SCA_DATE")

If InStr(HTMLsourcecode.body.innerhtml, "Your request timed out") > 0 Then
Debug.Print "timeout"
DelayTick (100)
r = r + 1
If r > 3 Then
MsgBox "請稍後再試", vbOKOnly, "Error"
Exit Sub
End If
GoTo retry1
End If
ReDim temp(1 To SCA_DATE.Length)
For i = 1 To SCA_DATE.Length
temp(i) = SCA_DATE(i - 1).innertext
Next i
End With

With Sheets("工作表1")
.ListBoxes("list_0").Delete
.ListBoxes("list_1").Delete
.Cells.Clear
Set list_0 = .ListBoxes.Add(.Range("a3").Left, .Range("a3").Top, 70, 400)
Set list_1 = .ListBoxes.Add(.Range("b3").Left, .Range("b3").Top, 70, 400)
With list_0
.Name = "list_0"
list_0.List = temp()
.Selected(7) = True
End With
With list_1
.Name = "list_1"
list_1.List = temp()
.Selected(1) = True
End With
.Cells.Font.Size = "10"
.Columns.AutoFit
.Cells(1, 1).Select
End With

Erase temp()
Set Getxml = Nothing
Set SCA_DATE = Nothing
Set HTMLsourcecode = Nothing

End Sub

Function convertraw(rawdata)

Dim rawstr
Set rawstr = CreateObject("adodb.stream")

With rawstr
.Type = 1
.Mode = 3
.Open
.Write rawdata
.Position = 0
.Type = 2
' .Charset = "utf-8"
.Charset = "big5"
convertraw = .ReadText
.Close
End With

Set rawstr = Nothing

End Function

Sub DelayTick(tick)

t = Timer
Do While (Timer - t) > tick
Loop

End Sub

'=====================================

附加壓縮檔: 201802/mobile01-1623860d2b5e58a4e0e652c78c115676.zip