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

2598分

個人積分：2598分

文章編號：83173644

nickchu wrote:
請教各位大大，小弟在抓取這個網址中的20年財報：
https://invest.cnyes.com/usstock/detail/DIS/financial/financials20yr

... 恕刪…

問題是在request url帶了token。我找遍了F12裡network所有的XHR，也沒看出那裡生出的token (似乎是隨機的，每次開browser都不同)。

cnyes?? token ?? 印像中，我寫過好幾個範例了…
271、272、274、631、751、1064……有些忘了
其中yahoo financial現在改版後不需要key也可以
只是程式碼中未刪掉，雖然是多餘的，但可參考寫法

這一頁的資料是先在這個網址，方式是POST

https://app.quotemedia.com/auth/g/authenticate/dataTool/v0/91386/d54dae6c8cf2bda0196be3a59647fcc4ee56671e9187d4388275abc155ea137c

正確請求到 token後，再套用到您找到的那ajax 網址，返回json
(要注意，如果您點了網頁中其它選項、頁面，請求token的網址，有可能會不同)

(點我看大圖)

json雖然很快(約0.6秒)，但這個您確定要用json整理
表格，是要一格一格排的，參數超多的喔……
而且有些股票代號，表格會改用不同的排列方式…
整理請加油，字太多了，我實在不想打

，希望您能整理出來分享

Sub Get_cnyes_Jsondata()

    Dim Xmlhttp As Object, Jsondata As Object, Url As String, Url_a As String, token As String, DecodeJson, ttt As Double, Stock As String
    Set Jsondata = CreateObject("HtmlFile")
    Set Xmlhttp = CreateObject("msxml2.xmlhttp")
    



    Sheets("工作表1").Cells.Clear
    
    Stock = "DIS" 'test
    'Stock = "AAPL"  'test



    Url = "https://app.quotemedia.com/auth/g/authenticate/dataTool/v0/91386/d54dae6c8cf2bda0196be3a59647fcc4ee56671e9187d4388275abc155ea137c"
    Url_a = "https://invest.cnyes.com/usstock/detail/" & Stock & "/financial/financials20yr"

    
    With Xmlhttp
       .Open "POST", Url, False
       .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
       .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"
       .setRequestHeader "Accept", "text/html,application/xhtml+xml,application/xml;q=0.9,image/webp,image/apng,*/*;q=0.8"
       .setRequestHeader "origin", "https://invest.cnyes.com"
       
       .send
       
       token = Split(Split(.responsetext, """token"" : """)(1), """")(0)
       
        Url = "https://app.quotemedia.com/datatool/getFinancialsEnhancedBySymbol.json?symbol=" & Stock & "&numberOfReports=20&latestfiscaldate=true?cy=true&reportType=A&token=" & token
 
       .Open "GET", Url, False
       .setRequestHeader "origin", "https://invest.cnyes.com"
       .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"
       .setRequestHeader "Referer", Url_a
       .send
       
       
       Set DecodeJson = CallByName(CallByName(Jsondata.JsonParse(.responsetext), "results", VbGet), "Company", VbGet)
        
       '===================================
      
       '整理 json 用的程式碼放這裡

       
         









       '===================================
        
        
    End With
    
    
    Set Xmlhttp = Nothing
    Set DecodeJson = Nothing
    Set Jsondata = Nothing
    
End Sub

另外，要注意，多筆查詢時，要有適當延遲，會擋ip的

nickchu

0分

1123樓

nickchu

個人積分：0分

文章編號：83179009

snare wrote:
cnyes?? token...(恕刪)

感謝版主大大，解決了token問題之後，後續就沒有問題了。
我最後整理json的方式，是參考網路上的解法，最主要是每一層的數量不一定，想要用同一段程式去處理，所以必須把下層的節點的數量算出來(用GetKeys這個function)，就可以用for去處理了。

貼上不專業程式碼：
'記得引用 Microsoft Script Control 1.0

InitScriptEngine '用javascript來處理json
Set Jsondata = CreateObject("HtmlFile")
Set Xmlhttp = CreateObject("msxml2.xmlhttp")
Jsondata.Write ""

With Xmlhttp
'在這裡再套stock迴圈可以抓多支股票代號----------
'XXXXX

Stock = "DIS"
Url = "https://app.quotemedia.com/datatool/getFinancialsEnhancedBySymbol.json?symbol=" & Stock & "&numberOfReports=20&latestfiscaldate=true?cy=true&reportType=A&token=" & token
Url_ref = "https://invest.cnyes.com/usstock/detail/" & Stock & "/financial/financials20yr"

.Open "GET", Url, False
.setRequestHeader "origin", "https://invest.cnyes.com"
.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"
.setRequestHeader "Referer", Url_ref
.send
If InStr(1, .responsetext, "Company") = 0 Then
GoTo next_Finance
End If
Set DecodeJson = CallByName(CallByName(CallByName(Jsondata.JsonParse(.responsetext), "results", VbGet), "Company", VbGet), "Report", VbGet)

'===================================
'整理 json 用的程式碼放這裡

'取出第一層的物件名稱，共20個(年)
periods = GetKeys(DecodeJson)

For i = 0 To UBound(periods)
'取出第2層的報表名稱
Set reports = GetObjectProperty(DecodeJson, periods(i))
'取出日期
reportdate = GetProperty(reports, "reportDate")

'取出Balance Sheet科目集合
If IsObject(reports.BalanceSheet) Then
acts = GetKeys(reports.BalanceSheet)

For j = 0 To UBound(acts)
'取出值
Value = GetProperty(reports.BalanceSheet, acts(j))
Next j
End If

'取出Income Statement科目集合
If IsObject(reports.IncomeStatement) Then
acts = GetKeys(reports.IncomeStatement)
For j = 0 To UBound(acts)
'取出值
Value = GetProperty(reports.IncomeStatement, acts(j))
Next j
End If

'取出CashFlow科目集合
If IsObject(reports.CashFlow) Then
acts = GetKeys(reports.CashFlow)
For j = 0 To UBound(acts)
'取出值
Value = GetProperty(reports.CashFlow, acts(j))
Next j
End If
Next i

'停3秒，避免block ip
Sleep 3000End With

附上4個用到的function：
Public Function GetProperty(ByVal JsonObject As Object, ByVal propertyName As String) As Variant
'可以直接取得某element的value
GetProperty = ScriptEngine.Run("getProperty", JsonObject, propertyName)
End Function

Public Function GetObjectProperty(ByVal JsonObject As Object, ByVal propertyName As String) As Object
'取某json物件的指定某一層名字的物件，類似callByName
Set GetObjectProperty = ScriptEngine.Run("getProperty", JsonObject, propertyName)
End Function

Public Function GetKeys(ByVal JsonObject As Object) As String()
'把某一層下的element name放到array裡，適用在不知道下層有多少個elements，也不知道每個element的名字時使用
Dim Length As Integer
Dim KeysArray() As String
Dim KeysObject As Object
Dim Index As Integer
Dim Key As Variant

Set KeysObject = ScriptEngine.Run("getKeys", JsonObject)
Length = GetProperty(KeysObject, "length")
ReDim KeysArray(Length - 1)
Index = 0
For Each Key In KeysObject
KeysArray(Index) = Key
Index = Index + 1
Next
GetKeys = KeysArray
End Function

Public Sub InitScriptEngine()
Set ScriptEngine = New ScriptControl
ScriptEngine.Language = "JScript"
ScriptEngine.AddCode "function getProperty(jsonObj, propertyName) { return jsonObj[propertyName]; } "
ScriptEngine.AddCode "function getKeys(jsonObj) { var keys = new Array(); for (var i in jsonObj) { keys.push(i); } return keys; } "
End Sub

2598分

個人積分：2598分

文章編號：83180241

nickchu wrote:
我最後整理json的方式，是參考網路上的解法

謝謝分享程式碼，不過為了將來都是x64的時代
建議您慢慢試著不要用Microsoft Script Control 1.0這種解法
因為它不能正常的在excel x64上執行

雖然想執行還是有方法，但需要很多行的前置程式碼做處理才行
如果初學者要看，實在太複雜，學習起來會非常辛苦
所以我的範例從2017年(219樓)開始，都用html script + callbyname的方式處理
因為相容性高、簡單，比較適合一般人學習

不然你也可使用國外高手寫好的1千多行
功能非常強大的json專用處理模組，要轉字串、陣列…什麼的都簡簡單單
(有興趣，請到這裡下載、學習)
https://github.com/VBA-tools/VBA-JSON

joehuang

20分

1125樓

joehuang

個人積分：20分

文章編號：83188233

snare wrote:
寫的不錯，圖表沒什麼(恕刪)

更新1117 樓功課:
謝謝樓主提醒,原來兩個資料不是對稱的.
我改了一下把他用日期為KEY 合併兩份資料.

程式調整如下:省略前後樓主提供的部份
'==================

'blueline、redline，json整理用程式碼放這裡

Dim BlueLineArr2() As String, RedLineArr2() As String

'記錄資料開始日期
Dim Start_DT As Date

ReDim BlueLineArr2(CallByName(BlueLine, "length", VbGet) - 1, 1)
ReDim RedLineArr2(CallByName(RedLine, "length", VbGet) - 1, 1)

'將BlueLine資料匯入2維陣列中
For i = 0 To CallByName(BlueLine, "length", VbGet) - 1
'取第1筆資料的日期當作資料開始日期
If i = 0 Then
Start_DT = CallByName(CallByName(BlueLine, i, VbGet), "0", VbGet)
End If

BlueLineArr2(i, 0) = CallByName(CallByName(BlueLine, i, VbGet), "0", VbGet)
BlueLineArr2(i, 1) = CallByName(CallByName(BlueLine, i, VbGet), "1", VbGet)

Next i

'將RedLine資料匯入2維陣列中
For i = 0 To CallByName(RedLine, "length", VbGet) - 1
RedLineArr2(i, 0) = CallByName(CallByName(RedLine, i, VbGet), "0", VbGet)
RedLineArr2(i, 1) = CallByName(CallByName(RedLine, i, VbGet), "1", VbGet)
Next i

Dim myFind As String
Dim foundBlueLineArr2, found2RedLineArr2 As Variant
Dim lastRedLine
lastRedLine = 0

'依日期合併兩組資料(多空比,指數) 因為兩組資料有不對稱情形
With Sheets("工作表1")
.Cells.Clear
.Range("a1:c1") = Array("日期", "多空比", "指數")

'記錄資料寫入位置
puti = 2

'處理最小資料到當日的資料
For i = 0 To Now() - Start_DT

myFind = Format(Start_DT + i, "yyyy-mm-dd")

'依日期找BlueLineArr2資料
foundBlueLineArr2 = Application.Match(myFind, Application.Index(BlueLineArr2, , 1), 0)
'依日期找RedLine資料
found2RedLineArr2 = Application.Match(myFind, Application.Index(RedLineArr2, , 1), 0)

'如果兩組資料都查不到有日期資料就不寫入EXCEL否則會有空格跑出來
If IsNumeric(foundBlueLineArr2) Or IsNumeric(found2RedLineArr2) Then
.Cells(puti, 1) = Start_DT + i

'依日期找BlueLineArr2資料結果處理
If IsNumeric(foundBlueLineArr2) Then
.Cells(puti, 2) = BlueLineArr2(foundBlueLineArr2 - 1, 1)
Else
'查無日期資料顏色註記
.Cells(puti, 2).Font.ColorIndex = 2
.Cells(puti, 2).Interior.ColorIndex = 30
'查無日期指數資料放0,不影圖表顯示
.Cells(puti, 2) = 0

End If

'依日期找RedLine資料結果處理
If IsNumeric(found2RedLineArr2) Then
.Cells(puti, 3) = RedLineArr2(found2RedLineArr2 - 1, 1)
lastRedLine = .Cells(puti, 3)
Else
'查無日期資料顏色註記
.Cells(puti, 3).Font.ColorIndex = 2
.Cells(puti, 3).Interior.ColorIndex = 30
'查無日期指數資料放入上一筆,為了圖表好看,放0趨勢圖會有一個到0的結果
.Cells(puti, 3) = lastRedLine
End If

'記錄寫入位置往後+1
puti = puti + 1
End If
Next i

'保留原始用2個迴圈的程式
'.Range("a1:d1") = Array("日期", "多空比", "日期", "指數")

'For i = 0 To CallByName(BlueLine, "length", VbGet) - 1
' .Cells(i + 2, 1) = CallByName(CallByName(BlueLine, i, VbGet), "0", VbGet)
' .Cells(i + 2, 2) = CallByName(CallByName(BlueLine, i, VbGet), "1", VbGet)
'Next i

'For i = 0 To CallByName(RedLine, "length", VbGet) - 1
' .Cells(i + 2, 3) = CallByName(CallByName(RedLine, i, VbGet), "0", VbGet)
' .Cells(i + 2, 4) = CallByName(CallByName(RedLine, i, VbGet), "1", VbGet)
'Next i

.Cells.Columns.AutoFit
End With

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

跟大家分享!

[點擊下載]

snare
樓主

整理資料時，各種小細節都注意到了，程式碼寫作能力高，屬於那種只要知道方法，就能獨自完成程式的高手，謝謝整理分享。

Dylan67

7分

1126樓

Dylan67

個人積分：7分

文章編號：83200444

Snare大神:

弄到凌晨搞不出來，還是得向您求救，

附件是我下載代碼的程式，前幾天使用是沒有問題的，

這兩天就失敗了(代碼中Url的網頁是打的開的)，

故想請您指教，是我那裡寫錯了，感謝。Dylan

[點擊下載]

2598分

個人積分：2598分

文章編號：83203669

Dylan67 wrote:
附件是我下載代碼的程式，前幾天使用是沒有問題的，

(20211010 15:48 測試)
ok啊???
跟股票有關的網站，通常都是在星期5、6、日，做維護、改版
您會不會剛好遇到所以無法下載?

Dylan67

我暈，居然真的又可以了，謝謝版主的回覆，不過這兩天真的好怪，網頁可以開，卻下載失敗，下回再發生類似情況，再請您瞧瞧什麼原因，真不明白為什麼，看來還要繼續努力學習，感謝

10分

1128樓

個人積分：10分

文章編號：83290781

Snare大您好, 換win11 and office2021, 執行程式出現 "執行階段錯誤'-2147352319 (8002019)' 'JsonParse'方法('JScriptTypeInfo'物件)失敗" ，試了些方法也無效，只好又來麻煩您。

Sub test()

Dim lastrow As Integer, i As Integer, ttt As Double

ttt = Timer
Cells.Clear
Sheets("工作表1").Range("a1:g1") = Array("stock", "date", "close", "stockAgentMainPower", "stockAgentDiff", "skp5", "skp20")

Application.ScreenUpdating = False

For i = 1 To 5 '測試5筆
Call WantGoo_Json_test(Choose(i, "2330", "2412", "2002", "2603", "2303"), i + 1)
Next i
Sheets("工作表1").Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True
Debug.Print Timer - ttt & "s"

End Sub

Sub WantGoo_Json_test(stock_id As String, lastrow As Integer)

Dim Xmlhttp As Object, Jsondata As Object, DecodeJson, Url As String, urla As String
Set Jsondata = CreateObject("HtmlFile")
Set Xmlhttp = CreateObject("Msxml2.XMLHTTP")

Jsondata.Write ""

Url = "https://www.wantgoo.com/stock/" & stock_id & "/major-investors/main-trend-data"
urla = "https://www.wantgoo.com/stock/" & stock_id & "/major-investors/main-trend"

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"
'.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64; rv:90.0) Gecko/20100101 Firefox/90.0"
.send
Application.Wait (Now + TimeValue("0:05:00"))

Set DecodeJson = Jsondata.JsonParse(.responseText)
End With

With Sheets("工作表1")
.Cells(lastrow, 1) = stock_id
.Cells(lastrow, 2) = Format(CallByName(CallByName(DecodeJson, 1, VbGet), "date", VbGet) / 86400000 + #1/1/1970 8:00:00 AM#, "yyyy/mm/dd")
.Cells(lastrow, 3) = CallByName(CallByName(DecodeJson, 0, VbGet), "close", VbGet)
.Cells(lastrow, 4) = CallByName(CallByName(DecodeJson, 0, VbGet), "stockAgentMainPower", VbGet)
.Cells(lastrow, 5) = CallByName(CallByName(DecodeJson, 0, VbGet), "stockAgentDiff", VbGet)
.Cells(lastrow, 6) = CallByName(CallByName(DecodeJson, 0, VbGet), "skp5", VbGet)
.Cells(lastrow, 7) = CallByName(CallByName(DecodeJson, 0, VbGet), "skp20", VbGet)
End With

Set Xmlhttp = Nothing
Set DecodeJson = Nothing

End Sub
謝謝您!

2598分

個人積分：2598分

文章編號：83292306

goldchiou wrote:
換win11 and office2021, 執行程式出現 "執行階段錯誤'-2147352319

這跟win11、office2021無關
是wantgoo取消支援ie(用ie會沒資料)、加上了ddos、加上了防爬蟲
所以舊範例全部不能用了

建議另找容易下載的來源，例如：1106樓 yahoo 主力進出範例
如果要跟wantgoo一樣的格式，找原始資料自己算就好

wantgoo有給計算方式

主力進出表格欄目計算公式
買賣超 = 前15大券商總買進張數 - 前15大券商總賣出張數
家數差 = 所有買超券商家數 - 所有賣超券商家數
5日集中度% = (買方前15名近5日總買超量 - 賣方前15名近5日總賣超量) / 近5日總成交量
20日集中度% = (買方前15名近20日總買超量 - 賣方前15名近20日總賣超量) / 近20日總成交量

除了wantgoo還有那個網站有資料，我就不清楚了，您要自己找
我是不分析的存股族，對我有用的只有收盤價
意外中籤，今天小賺13萬 ^++^

goldchiou

Snare大，謝謝您，我用python requests抓到也只有說明，只能用seleniun一個一個抓。恭喜賺13萬。

10分

1130樓