只是table後面數字有變動
-----------------------------------------
另外也感謝師兄弟的修整編輯
小弟省去了從原版擷取的時間
師傅~不好意思了
小弟這招,先偷抄走了
但目前仍以all.tags為主,這個剪貼的不知道在何時用會比較適合
無論如何,先把師父的招數記錄下來
用不同的來源測試:
Sub TEST3()
Cells.ClearContents
Dim HTMLsourcecode, Url, Url_a, Clipboard As Object
Set HTMLsourcecode = CreateObject("htmlfile")
Set Clipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
Url = "http://mops.twse.com.tw/mops/web/t163sb04"
Url_a = "encodeURIComponent=1&step=1&firstin=1&off=1&TYPEK=sii&year=106&season=01"
With CreateObject("WinHttp.WinHttpRequest.5.1")
.Open "POST", Url, False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.setRequestHeader "Referer", Url
.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 Url_a
HTMLsourcecode.body.innerhtml = convertraw(.ResponseBody)
Set Table = HTMLsourcecode.getelementbyid("table01")
With Clipboard
.SetText Table.innerhtml
.PutInClipboard
End With
With Sheets("工作表1")
.Select
.Cells.Clear
.Cells(1, 1).Select
.PasteSpecial NoHTMLFormatting:=True
.Columns.AutoFit
End With
End With
End Sub
個人感想
優點:
程式碼簡短,萬用!
缺點:
會把整個頁面載進去(包括多餘的資料),版面較亂
在觀測站速度似乎遜於all.tag
其中的web匯入功能,可以算是加強版的web匯入
舊版web匯入會出現的問題,在powerquery,都可以解決
甚至部份json格式的網站也可以正常匯入,可惜有些json還是無法處理
使用方式
資料=>新查詢=>從其它來源=>從web(這裡不要選錯了)=>輸入網址=>選要抓的table=>按載入
因為只是滑鼠點來點去
沒什麼好說明的,以下就看圖說故事
範例
yahoo 股市中鋼、台灣銀行牌告匯率、Goodinfo! 現股當沖張數、Yahoo匯率換算
至於無法處理的json網站,需要用powerquery的進階編輯器,來寫程式碼處理
方法有2
一、新增來源連結到別的網站上的api做解碼處理,可惜速度會更慢,網站不穩就不能解
二、自己寫程式碼,不過這個程式碼是 java ,每個要處理的網站,都要寫一個新的,無法通用
所以雖然我知道怎麼寫,但這裡就不多加介紹,因為對各位來說,會比vba還難上好幾倍
powerquery的其它用法,請自行google,不多做說明
powerquery處理速度,輸vba一大截,比較複雜json還要另外寫java處理
要下載資料,個人建議還是以vba為主,只要網頁打的開,就一定可以下載
這個是點選按鈕後,下載文字檔的範例,以前在269樓,就寫過了
這次寫法就是269樓的方式,只是簡單多了
這種網站主要的特徵是,點選下載後,才會出現檔名
https://rate.bot.com.tw/xrt?Lang=zh-TW
'==============================================================
'這個範例,跟269樓一樣,提供2種不同的下載方式
'==============================================================
Sub Get_rate_hd()
Dim Xmlhttp As Object, FileName As String, Url As String, ttt As Double
Set Xmlhttp = CreateObject("Msxml2.XMLHTTP")
ttt = Timer
Url = "https://rate.bot.com.tw/xrt/flcsv/0/day"
On Error Resume Next
With Xmlhttp
.Open "GET", Url, False
.setRequestHeader "Cache-Control", "no-cache"
.setRequestHeader "Pragma", "no-cache"
.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
.send
FileName = Replace(Replace(.getresponseheader("Content-Disposition"), "attachment; filename=", ""), """", "")
End With
With CreateObject("ADODB.Stream")
.Type = 1
.Open
.write Xmlhttp.ResponseBody
.savetofile ThisWorkbook.Path & "\" & FileName, 2
'預設存檔路徑,和工作表相同目錄
'注意:相同檔名的檔案,會在無任何提示下覆蓋
.Close
Workbooks.OpenText FileName:=ThisWorkbook.Path & "\" & FileName, Origin:= _
65001, StartRow:=1, DataType:=xlDelimited, Comma:=True, TrailingMinusNumbers:=True
Cells.Columns.AutoFit
MsgBox FileName & vbNewLine & "資料筆數" & ActiveSheet.Range("a1").CurrentRegion.Rows.Count - 1 & "筆" & _
vbNewLine & "下載使用時間" & Timer - ttt & "秒" & _
vbNewLine & "牌價最新掛牌時間:" & Format(Mid(FileName, 14, 12), "####-##-## ##:##"), vbOKOnly
End With
Windows(FileName).Activate
ActiveWindow.WindowState = xlMaximized
Set Xmlhttp = Nothing
End Sub
Sub Get_rate_memory()
Dim Xmlhttp As Object, Clipboard As Object, Url As String, Update As String, ttt As Double
Set Clipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
Set Xmlhttp = CreateObject("Msxml2.XMLHTTP")
ttt = Timer
Url = "https://rate.bot.com.tw/xrt/flcsv/0/day"
On Error Resume Next
With Xmlhttp
.Open "GET", Url, False
.setRequestHeader "Cache-Control", "no-cache"
.setRequestHeader "Pragma", "no-cache"
.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
.send
Update = Left(Split(Xmlhttp.getresponseheader("Content-Disposition"), "@")(1), 12)
End With
Clipboard.SetText Xmlhttp.responsetext
Clipboard.PutInClipboard
With Sheets("工作表1")
.Select
.Rows("4:" & .Rows.Count).ClearContents
.Cells(4, 1).Select
.PasteSpecial NoHTMLFormatting:=True
Selection.TextToColumns DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, Comma:=True
.Columns.AutoFit
.Cells(1, 1).Select
MsgBox "不存檔直接開啟" & vbNewLine & "牌價最新掛牌時間" & Format(Update, "####/##/## ##:##") & vbNewLine _
& "資料筆數" & .Range("a4").CurrentRegion.Rows.Count - 1 & "筆" & vbNewLine & "下載使用時間" & Timer - ttt & "秒", vbOKOnly, "下載完成"
End With
Set Xmlhttp = Nothing
Set Clipboard = Nothing
End Sub
'===============================================================
[點擊下載]
關閉廣告