個人積分：1分
文章編號：82556813
小弟使用多年的Code近期遇到yahoo改版問題，嘗試過更改不同table也是無法抓到股價資訊，小弟眼拙，想請snare大解惑!~ 萬分感謝!!
-----------------------------------------------------------------------------------------------------------------------------------------
Sub YahooStock()
Dim i As Integer, j As Integer
Dim XMLHTTP As Object
Set XMLHTTP = CreateObject("Microsoft.XMLHTTP") '後期綁定建立Xmlhttp連線物件與DOM物件
Dim DOM As Object
Set DOM = CreateObject("HTMLFile") '後期綁定建立Xmlhttp連線物件與DOM物件
Dim Table As Object
On Error Resume Next
i = 2
With XMLHTTP
Do While Cells(2 + QQ, 1) <> ""
'2019/1/3 因為0056代號關係，故增加此行 AA = Right("0000" & Cells(2 + QQ, 1), 4)
aa = Right("0000" & Cells(2 + QQ, 1), 4)
'下行 AA取代原本的 Cells(2 + QQ, 1)
.Open "GET", "https://tw.stock.yahoo.com/q/q?t=" & Timer & "&s=" & aa, False '同步方式開啟請求連線
.setRequestHeader "Cache-Control", "no-cache"
.setRequestHeader "Pragma", "no-cache"
.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
.send '進行網頁連線
If .Status = 200 Then
'把傳回值轉成標準htmlfile
DOM.body[removed] = .responseText
End If
Set Table = DOM.getElementsByTagName("table")(2)
For j = 1 To 10
Cells(i, j + 1) = Table.Rows(1).Cells(j).innerText
Next
...
...
請參考999樓、1000樓範例
個人積分：3107分
文章編號：82557127
辦理私募之應募人為內部人或關係人
下載範例
'點擊g欄，註解會下載到e欄
'如果不想用註解，可另寫vba(或公式) call Function Get_twse_詳細資料(url As String)，寫到儲存格裡
'===程式碼放在模組===
Sub Get_twse_即時重大訊息()
Dim HTML As Object, Getxml As Object, table As Object, i As Integer, j As Integer, url As String, Url_a As String, ttt As Double
Dim Ie_Open As Boolean
'Ie_Open = True '使用超連結，點擊插入註解，打開瀏覽器
Ie_Open = False '使用文字格式網址，點擊插入註解，但不打開瀏覽器(d欄、f欄，維持超連結格式)
Set HTML = CreateObject("htmlfile")
Set Getxml = CreateObject("msxml2.xmlhttp")
url = "https://mops.twse.com.tw/mops/web/ajax_t116sb01_new "
Url_a = "https://mops.twse.com.tw/mops/web/ajax_t116sb01"
ActiveSheet.Cells.Clear
Application.ScreenUpdating = False
ttt = Timer
With Getxml
.Open "POST", url, False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.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 ("encodeURIComponent=1&step=1&firstin=1&off=1&TYPEK=sii")
HTML.body.innerhtml = .responsetext
End With
Set table = HTML.all.tags("table")(0).Rows
Dim PostData As String, report_type As String, co_id As String, decide_date As String, stock_kind As String, year_Value As String, SEQ_NO As String
For i = 0 To table.Length - 1
For j = 0 To table(i).Cells.Length - 1
If (j = 3 Or j = 5 Or j = 6) And i > 0 And table(i).Cells(j).innerhtml <> " " Then
PostData = table(i).Cells(j).innerhtml
report_type = Split(Split(PostData, "report_type.value='")(1), "'")(0)
co_id = Split(Split(PostData, "co_id.value='")(1), "'")(0)
decide_date = Split(Split(PostData, "decide_date.value='")(1), "'")(0)
stock_kind = Split(Split(PostData, "stock_kind.value='")(1), "'")(0)
If j <> 3 Then
year_Value = Split(Split(PostData, "year.value='")(1), "'")(0)
SEQ_NO = Split(Split(PostData, "seq_no.value='")(1), "'")(0)
End If
PostData = Url_a & "?encodeURIComponent=1&firstin=true&TYPEK=sii&step=2&report_type=" & report_type & "&co_id=" & co_id & "&decide_date=" & decide_date & "&stock_kind=" & stock_kind & "&year=" & year_Value & "&seq_no=" & SEQ_NO & "&ys="
If (Ie_Open = True Or j = 3 Or j = 5) Then
ActiveSheet.Hyperlinks.Add ActiveSheet.Cells(i + 1, j + 1), Address:=PostData, TextToDisplay:="詳細資料"
Else
ActiveSheet.Cells(i + 1, j + 1) = PostData
End If
Else
ActiveSheet.Cells(i + 1, j + 1) = Trim(table(i).Cells(j).innertext)
End If
Next j
Next i
'ActiveSheet.Columns.AutoFit
Application.ScreenUpdating = True
Set HTML = Nothing
Set Getxml = Nothing
Set table = Nothing
Debug.Print Timer - ttt & "s(download link)"
End Sub
'=====================
'===程式碼放在工作表1===
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If InStr(CStr(Target.Address), ":") > 0 Then Exit Sub
If Target.Count > 1 Then Exit Sub
If Target.Value = "" Then Exit Sub
If Intersect(Target, Columns("G:G")) Is Nothing Then
' out
Else
If Target.Offset(, -2).Comment Is Nothing Then
' no old comment
Else
If InStr(Target.Offset(, -2).Comment.Text, "查詢過於頻繁") = 0 Then
'download ok
Exit Sub
Else
Target.Offset(, -2).ClearComments
End If
End If
If Target.Value = "詳細資料" Then
Target.Offset(, -2).AddComment.Text Get_twse_詳細資料(Target.Hyperlinks.Item(1).Address)
Else
If Target.Value <> "股款或價款繳納完成日起十五日內應申報相關資訊" Then
Target.Offset(, -2).AddComment.Text Get_twse_詳細資料(Target.Value)
End If
End If
If Target.Row > 1 Then Target.Offset(, -2).Comment.Shape.TextFrame.AutoSize = True
End If
End Sub
Function Get_twse_詳細資料(url As String) As String
Dim HTML As Object, Getxml As Object, ttt As Double
Set HTML = CreateObject("htmlfile")
Set Getxml = CreateObject("msxml2.xmlhttp")
ttt = Timer
With Getxml
.Open "POST", url, False
.setRequestHeader "Referer", "https://mops.twse.com.tw/mops/web/t116sb01_new"
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.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
HTML.body.innerhtml = .responsetext
End With
If InStr(HTML.body.innertext, "查詢過於頻繁") > 0 Then
Get_twse_詳細資料 = HTML.body.innertext
Else
Get_twse_詳細資料 = _
"到期日期" & vbNewLine & _
Split(Split(HTML.body.innertext, "到期日期")(1), "定價日期")(0) & vbNewLine & _
"私募總金額" & vbNewLine & _
Split(Split(HTML.body.innertext, "價格訂定依據")(0), "本次私募總金額")(1)
End If
Set HTML = Nothing
Set Getxml = Nothing
Set table = Nothing
Debug.Print Timer - ttt & "s"
End Function
'==========================
[點擊下載]
感謝snare 大 的指導
個人積分：5分
文章編號：82569804
個人積分：3107分
文章編號：82577909
dolter29 wrote:
大大，我試了很多方式，為什麼google的熱搜趨勢資料一直抓不下來，CSV也沒辦法載 @@
老實說，我不太想寫這個範例
其它人發問時，大部份都會貼個程式碼
或是有去找看看文章是否有類似的，知道是哪一樓範例
看了您平常完全不發言的老帳號
又看到投資理財區，出現了很多用excel股市資料，在打廣告的帳號
我懷疑您真的有試了很多方式、練習過嗎?
(是否能po個練習檔案上來看看)
測試一下google 熱搜趨勢，發現其實類似的下載方式，我都有寫過範例
所以還是寫一下好了
我有先google過，熱搜趨勢改版後
目前沒人成功用純vba xmlhttp 方式，寫過"熱搜趨勢關鍵字下載"範例
我不知道您要用來做什麼、跟投資理財區的excel有沒有關係
(您可自用，可發文、轉po需註明資料來源)
' google 每日搜尋趨勢
'沒什麼特別技巧，很單純，只有json資料而己
'(點我看大圖)
Sub google_trends_everyday()
Dim Xmlhttp As Object, Jsondata As Object, DecodeJson, Url As String
Set Jsondata = CreateObject("HtmlFile")
Set Xmlhttp = CreateObject("Msxml2.XMLHTTP")
Url = "https://trends.google.com.tw/trends/api/dailytrends?hl=zh-TW&tz=-480&geo=TW&ns=15"
With Xmlhttp
.Open "GET", Url, False
.setRequestHeader "Content-Type", "application/json; charset=utf-8"
.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/92.0.4515.107 Safari/537.36"
.send
Set DecodeJson = Jsondata.JsonParse(Right(.responsetext, Len(.responsetext) - 6))
End With
'json資料，請參考其它範例，自行從變數DecodeJson中整理出來
Set Xmlhttp = Nothing
Set Jsondata = Nothing
End Sub
' google 搜尋趨勢(關鍵字查詢)
'關鍵字稍微麻煩一些
'一、要先取得token
'二、網址送出時，要先編碼
'(點我看大圖)
Sub google_trends_keyword()
Dim Xmlhttp As Object, Jsondata As Object, DecodeJson, Url As String, Urla As String, Urlb As String, UrlC As String, keyword As String, token As String, dayRange As String, temp, i As Integer
Set Jsondata = CreateObject("HtmlFile")
Set Xmlhttp = CreateObject("Msxml2.XMLHTTP")
keyword = "台積電" 'test
'keyword = "聯電" 'test
'keyword = "鴻海" 'test
Cells.Clear
Url = "https://trends.google.com.tw/trends/api/explore?hl=zh-TW&tz=-480&req=" & UrlEncode("{""comparisonItem"":[{""keyword"":""" & keyword & """,""geo"":""TW"",""time"":""today 12-m""}],""category"":0,""property"":""""}") & "&tz=-480"
Urla = "https://trends.google.com.tw/trends/explore?q=" & keyword & "&geo=TW"
With Xmlhttp
.Open "GET", Url, False
.setRequestHeader "Content-Type", "application/json; charset=utf-8"
.setRequestHeader "Referer", Urla
.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/92.0.4515.107 Safari/537.36"
.send
token = Split(Split(Xmlhttp.responsetext, """token"":""")(1), """,""id"":")(0)
dayRange = Split(Split(Xmlhttp.responsetext, """:{""time"":""")(1), """,""resolution"":""")(0)
'========Json 格式資料========
'預設不下載
'Json資料比較豐富，有需要可從DecodeJson變數中，整理出想要的資料
'整理方式請參考其它範例
'Urlb = "https://trends.google.com.tw/trends/api/widgetdata/multiline?hl=zh-TW&tz=-480&req=" & _
UrlEncode("{""time"":""dayRange"",""resolution"":""WEEK"",""locale"":""zh-TW"",""comparisonItem"":[{""geo"":{""country"":""TW""},""complexKeywordsRestriction"":{""keyword"":[{""type"":""BROAD"",""value"":""" & keyword & """}]}}],""requestOptions"":{""property"":"""",""backend"":""IZG"",""category"":0}}") & "&token=" & token & "&tz=-480"
'Urlb = Replace(Replace(Replace(Urlb, "%3A", ":"), "%2C", ","), "dayRange", Replace(dayRange, " ", "+"))
'.Open "GET", Urlb, False
'.setRequestHeader "Content-Type", "application/json; charset=utf-8"
'.setRequestHeader "Referer", Urla
'.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/92.0.4515.107 Safari/537.36"
'.send
'Set DecodeJson = Jsondata.JsonParse(Right(.responsetext, Len(.responsetext) - 5))
'===========================
'========CSV 格式資料========
UrlC = "https://trends.google.com.tw/trends/api/widgetdata/multiline/csv?req=" & _
UrlEncode("{""time"":""" & dayRange & """,""resolution"":""WEEK"",""locale"":""zh-TW"",""comparisonItem"":[{""geo"":{""country"":""TW""},""complexKeywordsRestriction"":{""keyword"":[{""type"":""BROAD"",""value"":""" & keyword & """}]}}],""requestOptions"":{""property"":"""",""backend"":""IZG"",""category"":0}}") & "&token=" & token & "&tz=-480"
.Open "GET", UrlC, False
.setRequestHeader "Content-Type", "application/json; charset=utf-8"
.setRequestHeader "Referer", Urla
.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/92.0.4515.107 Safari/537.36"
.send
temp = Split(.responsetext, Chr(10))
For i = 0 To UBound(temp)
If i > 1 And temp(i) <> "" Then
Cells(i + 1, 1) = Split(temp(i), ",")(0)
Cells(i + 1, 2) = Split(temp(i), ",")(1)
Else
Cells(i + 1, 1) = temp(i)
End If
Next i
'===========================
End With
'========另存csv檔==================
'預設不存檔，有需要，請自行啟用
'With CreateObject("ADODB.Stream")
' .Charset = "utf-8"
' .Open
' .writetext Xmlhttp.responsetext
' .savetofile ThisWorkbook.Path & "\" & keyword & ".csv", 2
' .Close
'End With
'====================================
Cells.EntireColumn.AutoFit
Set Xmlhttp = Nothing
Set Jsondata = Nothing
Set DecodeJson = Nothing
End Sub
'這是圖片，請手動輸入
[點擊下載]
個人積分：5分
文章編號：82595444
附上我寫的抓股票資料的EXCEL檔，主要是結合這邊學到的程式
我會先抓全股票的前3名買超券商後
再依觀察中的券商去比對是否有在前3名
如果是有在前3名的話，則再比對熱搜趨勢是否往上，如果是的話就列出來
最後還是要感謝您的幫忙，謝謝
[點擊下載]
個人積分：3107分
文章編號：82598454
dolter29 wrote:
造成您的困擾非常抱歉
(恕刪)
不好意思，這是我的習慣，回文前都會先看一下發問者的文章、註冊日期
dolter29 wrote:
附上我寫的抓股票資料的EXCEL檔，主要是結合這邊學到的程式(恕刪)
裡面的 querytable，可改用xmlhttp
histock，只要5秒左右
yuanta，還不到0.1秒
Sub Get_Histock()
Dim URL As String, HTML As Object, GetXml As Object, Table, ttt As Double
Set HTML = CreateObject("htmlfile")
Set GetXml = CreateObject("msxml2.xmlhttp")
Cells.Clear
Application.ScreenUpdating = False
ttt = Timer
URL = "https://histock.tw/stock/rank.aspx?p=all"
With GetXml
.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
HTML.body.innerhtml = .responsetext
Set Table = HTML.all.tags("table")(0).Rows
For i = 0 To Table.Length - 1
For j = 0 To Table(i).Cells.Length - 1
If j = 0 Then Cells(i + 1, j + 1).NumberFormat = "@"
Cells(i + 1, j + 1) = Table(i).Cells(j).innertext
Next j
Next i
End With
Debug.Print Timer - ttt
Application.ScreenUpdating = True
Set HTML = Nothing
Set GetXml = Nothing
End Sub
http://jdata.yuanta.com.tw/z/zg/zg_AB_1_0.djhtm
寫法同上，table改("table")(2)
個人積分：5分
文章編號：82613978
但元大網如果要下載全部股票的話速度還是慢了一些
我測試的結果：
histock，大概6秒左右
yuanta，大概16秒左右
不過都比原來的querytable快上很多
感謝
[點擊下載]
個人積分：0分
文章編號：82616653
有關Yahoo股票股利查詢的頁面已完全改版,且將舊版的連結資料拿掉了,所以使用999樓的改版程式碼,新舊版網址均無法取得TABLE資料,經查.responsetext內,好像無TABLE資料,且新版的頁面顯示1991-2020年的股利資料;若僅需取得最近9年的股利資料,請問程式碼應如何修正?
部份程式碼:
Set HTMLsourcecode = CreateObject("htmlfile")
Set GetXml = CreateObject("WinHttp.WinHttpRequest.5.1")
舊版網址'URL = "https://tw.stock.yahoo.com/d/s/dividend_2303.html"
新版網址 URL = "https://tw.stock.yahoo.com/quote/2303/dividend"
With GetXml
.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
HTMLsourcecode.body.innerhtml = .responsetext
Debug.Print .responsetext
舊版股利頁面圖:URL = "https://tw.stock.yahoo.com/d/s/dividend_2303.html"
新版股利頁面圖:URL = "https://tw.stock.yahoo.com/quote/2303/dividend"
個人積分：3107分
文章編號：82617148
activer wrote:
有關Yahoo股票股利查詢的頁面已完全改版,且將舊版的連結資料拿掉了,所以使用999樓的改版程式碼,新舊版網址均無法取得TABLE資料
999樓範例，使用舊版股利連結、舊版下載範例，.send 上面多加一行
.setRequestHeader "user-agent", "Mozilla/5.0 (Windows NT 6.1; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/92.0.4515.107 Safari/537.36"
("table")(2) 改成 ("table")(3)
但不確定會不會再改
同個網址，不同瀏覽器，可以開出不同網頁
同瀏覽器相同網址，網頁有時也變來變去的
單筆下載還沒問題，但多筆下載測試的結果，每天都不太一樣
其實yahoo相關文章，2星期前就整理好了
追踨網頁程式碼時，結果時好時壞，有時還遇到一堆bug，有時被擋ip
似乎還在改，所以改版文章一直保留未po
個人積分：3107分
文章編號：82617589
dolter29 wrote:
histock，大概6秒左右
yuanta，大概16秒左右
不過都比原來的querytable快上很多
yuanta下載資料時，如果innertext是空白的，可改用innerhtml來拆字
Cells(S, j + 1).NumberFormat = "@"
Cells(S, j + 1) = Split(Split(Split(Table(i).Cells(j).innerhtml, "('")(1), "')")(0), "', '")(0)
Cells(S, j + 2) = Split(Split(Split(Table(i).Cells(j).innerhtml, "('")(1), "')")(0), "', '")(1)
看起來yuanta可暫時來代替改版中的yahoo查詢
snare ，有耶!用innerhtml就比較不會出問題，確實用yuanta感覺比較穩定一點，可能比較少人用他，所以他網頁變動的頻率就比較少吧，謝謝你
