• 114

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

板大以及各位高手午安:



今有一陣列公式 A2~F101
用迴圈依序執行AD2~AD31的代號
可得陣列計算後的數值
欄位 AE1的數值為陣列計算後, B101的數值
欄位 AF1的數值為陣列計算後, E101的數值

當執行完AD2的代號, 將AE1記錄在AE2, 將AF1記錄在AF2
當執行完AD3的代號, 將AE1記錄在AE3, 將AF1記錄在AF3
當執行完AD4的代號, 將AE1記錄在AE4, 將AF1記錄在AF4
....依此類推,記錄到AE31, AF31

目前遇到的問題是, AE, AF欄位有些數字, 有些卻沒記錄數字, 不知道是哪裡出問題?
請各位大神幫忙, 感激不盡

以下為我的VBA程式
= = = = = = = = = = = = = = = = = = = = = =

Sub 一鍵更新()

'先關閉螢幕更新(最後再開啟,會更新得快一點)
Application.ScreenUpdating = False

For i = 2 To 31

'代號
CCode = Sheets("Data").Cells(i, "AD")

'更新且計算公式陣列
Sheets("Data").Range("A2:F101").FormulaArray = "=XQLITE|Kline!'" & CCode & ".TW-Day-100'"

'複製計算後的數據,並依代號, 貼到相對應的位置
Range("AE1:AF1").Select
Selection.Copy
Range("AE" & i & ":AF" & i).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Next i

End Sub
alantsai5840

Sub Delaytick 為SNARE 大的 可以版上找

2021-09-04 18:53
snare

沒注意到是XQ dde ,dde 確實要有適當的延遲才行,感謝alantsai5840指出我的錯誤,幫忙回答修正

2021-09-04 19:08
請問yahoo的舊版股價VBA是不是完全抓不到資料了?
昨天開始就全部抓不到,之前是一直會有幾檔抓不到,要持續抓好幾次才會抓齊。
目前用的是底下這個routine,把重試次數設很大也是抓不到資料…

Sub getstock(firstdata, lastdata, lastrow)

Dim Url, HTMLsourcecode, GetXml
Dim Stock As String

For k = firstdata To lastdata
Stock = Sheets("TW.Stock").Cells(k, 1)
quotelen = Len(Stock)

DoEvents
Set HTMLsourcecode = CreateObject("htmlfile")
Set GetXml = CreateObject("msxml2.xmlhttp")
Url = "https://tw.stock.yahoo.com/q/q?s=" & Sheets("TW.Stock").Cells(k, 1)

retry:
Set Html = CreateObject("htmlfile")
Set GetXml = CreateObject("WinHttp.WinHttpRequest.5.1")

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
Debug.Print Html.All.tags("table").Length

If Html.All.tags("table").Length = 0 Then
re = re + 1
Debug.Print "retry:" & re
If re > 5 Then
ActiveSheet.Cells(1, 1) = "下載失敗"
Exit Sub
End If

Delaytick (0.5)
Set Html = Nothing
Set GetXml = Nothing
GoTo retry
End If

Set Table = Html.All.tags("table")(2).Rows
~ coco (nijawang) ~ 蔬食抗暖化,減碳救地球!
nijawang

可是我掛VPN再抓還是空空的…

2021-09-15 18:30
nijawang

另外是我同樣抓台灣Yahoo的美股VBA就正常。

2021-09-15 18:33
nijawang wrote:
請問yahoo的舊版股價VBA是不是完全抓不到資料了?
(恕刪)


這一陣子同個網址,新、舊版,變來變去的
程式碼也要改來改去的,有點煩,所以我都沒修正程式碼
(20210913 測試時,舊版還在)

今天,舊版網頁沒了,整個畫面都不一樣
格式不對,當然抓不下來

也如cji3cj6xu6,說的一樣,某些資料大量下載時,有擋ip
我再1069樓有測試時,有發現這個現象

這次網頁大概不會再改了,有空我再修正
cji3cj6xu6

想說偷師Snare 大在247F所提的,採Web方式騙yahoo,沒料到還是無法通行,尤其前兩天只有少數幾個無法下載,這兩天就完全不行,於是就猜測是IP被擋住了。呵呵~~~

2021-09-15 22:51
yahoo程式碼修正,暫時完成,新版網頁穩定性還不錯,測1000筆,都沒出現下載失敗,每筆大約0.3秒
開盤後測試看看再po

snare

回cji3cj6xu6:同一個網址,多按幾次F5,之前會突然出現舊版,現在不會

2021-09-16 16:57
cji3cj6xu6

謝謝Snare 大,我再參詳參詳。

2021-09-17 17:16
這次yahoo改版,真是多災多難…這幾個月來,網頁一直變來變去的
目前是改成2021-06-08 1:30 1024樓,yahoo 範例的格式,猜測現在接近最終版
原理可去1024樓看,這裡不多做說明

(1024樓,因yahoo改版,range("b1")字串要重新整理)
(會的請自行修改,直接不要b1也行,其它下載功能都正常,有空我再改)



有人知道舊版的“張數”是對應新版網頁中的那一格嗎?
(經nijawang指導,張數問題已解決)

https://tw.stock.yahoo.com/q/q?s=2330








範例中的排版方式,維持舊版
避免有人用這個格式寫程式、公式,排版一變,那全部要重寫,很麻煩的


'程式碼放到模組裡
'暫時用on error resume next 做個簡單除錯,因為不知道網頁會不會再改
'各筆之間的下載時間延遲(Delaytick),好像可以不用,有需要請自行啟用
'fake_Multiplex() 副程式,也可改用1098樓寫法替換,不影響功能有興趣自行替換


Global DownloadError As Integer

Sub fake_Multiplex()

Dim i As Integer, j As Integer, LastRow As Integer, Firstdata As Integer, Lastdata As Integer, t As Double, ErrorStock As Integer
t = Timer
DownloadError = 0
LastRow = Sheets("stock").Range("a1").CurrentRegion.Rows.Count
Sheets("stock").Range("b2:l" & LastRow).Clear: Sheets("stock").Range("n1:n3") = ""

If LastRow Mod 5 > 0 Then j = Int(LastRow / 5) + 1 Else j = Int(LastRow / 5)

For i = 1 To j
DoEvents
If i = 1 Then Firstdata = 2 Else Firstdata = (i - 1) * 5 + 1
If i = j Then
Lastdata = LastRow
Else
Lastdata = (i - 1) * 5 + 5
End If
'修正nijawang 1097樓,發現的一個小bug,請自行修改附件中的程式碼
Sheets("stock").Range("n1") = "Loading " & Round((i / j) * 100) & "%"
Call getstock(Firstdata, Lastdata)
Next i


With Sheets("stock")
If DownloadError > 0 Then Call Redownload
If DownloadError > 0 Then .Range("n2") = DownloadError & " 下載失敗"
.Range("n1") = LastRow - 1 - DownloadError & " stock loading ok"
.Cells.EntireColumn.AutoFit
End With


Debug.Print Timer - t


End Sub

Sub Redownload()

If DownloadError = 0 Then Exit Sub

Dim i As Integer, LastRow As Integer
LastRow = Sheets("stock").Range("a1").CurrentRegion.Rows.Count

For i = 5 To 0 Step -1
Delaytick (1)
Sheets("stock").Range("n3") = DownloadError & "筆失敗=>" & i & "秒後,重新下載"
Next i

DownloadError = 0
Sheets("stock").Range("n3") = ""

For i = 2 To LastRow
If Sheets("stock").Cells(i, 2) = "下載失敗" Then
Sheets("stock").Cells(i, 2) = ""
Call getstock(i, i)
End If
Next i

End Sub

Sub getstock(Firstdata As Integer, Lastdata As Integer)

Dim URL As String, GetXml As Object, Jsondata As Object, DecodeJson, temp As String, DataTime As String, i As Integer, j As Integer, k As Integer

On Error Resume Next

For k = Firstdata To Lastdata

DoEvents
URL = "https://tw.stock.yahoo.com/q/q?s=" & Sheets("stock").Cells(k, 1)

Set GetXml = CreateObject("WinHttp.WinHttpRequest.5.1")
Set Jsondata = CreateObject("HtmlFile")




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

DataTime = Split(Split(.responsetext, "datatime=""")(1), """>")(0)
'(20210917,縮短split判斷用字串,避免部份格式不同的代碼無法下載)
temp = "{""quote"":{""data"":" & Split(Split(.responsetext, """quote"":{""data"":")(1), ",""orderbook"":")(0) & "}}}"

Set DecodeJson = CallByName(CallByName(Jsondata.JsonParse(temp), "quote", VbGet), "data", VbGet)

With Sheets("stock")

.Cells(k, 2) = CallByName(DecodeJson, "symbolName", VbGet)
.Cells(k, 3) = DataTime 'CallByName(DecodeJson, "regularMarketTime", VbGet)
.Cells(k, 4) = CallByName(DecodeJson, "price", VbGet)
.Cells(k, 5) = CallByName(DecodeJson, "bid", VbGet)
.Cells(k, 6) = CallByName(DecodeJson, "ask", VbGet)

.Cells(k, 7) = CallByName(DecodeJson, "changePercent", VbGet)
If .Cells(k, 7).Value > 0 Then .Cells(k, 7).Font.Color = -16776961 _
Else If .Cells(k, 7).Value < 0 Then .Cells(k, 7).Font.Color = -11489280

'.Cells(k, 8) ' i don't know
'(經nijawang指導,這行修正如下)
.Cells(k, 8) = CallByName(DecodeJson, "volume", VbGet)/1000
.Cells(k, 9) = CallByName(DecodeJson, "regularMarketPreviousClose", VbGet)
.Cells(k, 10) = CallByName(DecodeJson, "regularMarketOpen", VbGet)
.Cells(k, 11) = CallByName(DecodeJson, "regularMarketDayHigh", VbGet)
.Cells(k, 12) = CallByName(DecodeJson, "regularMarketDayLow", VbGet)

If .Cells(k, 2) = "" Then
.Cells(k, 2) = "下載失敗"
DownloadError = DownloadError + 1
End If

End With

End With

Set GetXml = Nothing
Set Jsondata = Nothing
Set DecodeJson = Nothing
'Delaytick (0.3)

Next k


End Sub


Sub Delaytick(setdelay As Single)

Dim StartTime As Double, NowTime As Double
StartTime = Timer * 100
setdelay = setdelay * 100
Do
NowTime = Timer * 100
DoEvents
Loop Until NowTime - StartTime > setdelay

End Sub




(經nijawang指導,張數問題已解決)
請自行修改附件中的程式碼
'.Cells(k, 8) ' i don't know
改成
.Cells(k, 8) = CallByName(DecodeJson, "volume", VbGet)/1000



如果有人想要用舊版的漲、跌,代替正負號



把這行

If .Cells(k, 7).Value > 0 Then .Cells(k, 7).Font.Color = -16776961 _
Else If .Cells(k, 7).Value < 0 Then .Cells(k, 7).Font.Color = -11489280

換成下面這幾行

'debug.print vartype(CallByName(DecodeJson, "changePercent", VbGet)) ' 8 = string
Dim changePercent As Double
changePercent = .Cells(k, 7)
If changePercent > 0 Then
.Cells(k, 7).Value = "▲" & changePercent * 100 & "%"
.Cells(k, 7).Font.Color = -16776961
ElseIf changePercent < 0 Then
.Cells(k, 7).Value = Replace(changePercent * 100, "-", "▼") & "%"
.Cells(k, 7).Font.Color = -11489280
End If



[點擊下載]
snare

這樓範例是下載股票,不是下載大盤指數,2個是不同格式不能共用,有需要可用finance yahoo下載(271、272、274樓)

2021-09-17 0:05
kunlingame

重試後修正成功 謝謝snare版大

2021-09-18 19:53
感謝snare大的新版Yahoo!VBA。

延續我前面的留言。
之前我用舊版VBA,同樣以代碼^TWII從台灣Yahoo!抓大盤指數沒有問題。
因為網頁格式是一樣的。

至於新版Yahoo!,我比較了一下網頁格式,股票跟大盤也是一樣。
https://tw.stock.yahoo.com/q/q?s=2330

https://tw.stock.yahoo.com/q/q?s=^TWII


看了網頁原始碼,好像也差不多。


我再找時間處理看看。
謝謝!
~ coco (nijawang) ~ 蔬食抗暖化,減碳救地球!
snare

(2021年9月17日 週五 上午10:41,全新Yahoo奇摩股市個股頁上線),剛發現原來今天上午yahoo有發新聞稿,看來今天改版都完成了。不好意思,昨天看到的是另一個版本。

2021-09-17 21:10
cji3cj6xu6

Nija大,仔細看了你的說明,發現yahoo 之前用的是^twii,現在改為^TWII,難怪.....,我剛試了999F,1000F的程式,發現可以抓下來了,你試看看。

2021-09-18 21:34
感謝snare大與c大的說明!目前已可以下載^TWII加權指數了!

不過發現有個小問題:
在O1上的下載%,最後會停留在91%,但因為馬上被50 stock蓋過去,所以看不到…
底下這一行code好像應該要放在End If之後,才會在最後顯示100%。
~ coco (nijawang) ~ 蔬食抗暖化,減碳救地球!
cji3cj6xu6

Snare 大,真是位SW人,有錯必認。服你了。的確我也認為應該是下載完成,就認為100%了,沒料到有錯。Nija大,看的真是細,也服你了。

2021-09-19 0:00
nijawang

我只是比較習慣看%,不過後來想想,snare這樣設定也沒錯,因為最後就跳到loading了多少筆記錄,也就等於100%。

2021-09-19 22:44
nijawang wrote:
在O1上的下載%,最後會停留在91%,但因為馬上被50 stock蓋過去,所以看不到…
底下這一行code好像應該要放在End If之後,才會在最後顯示100%。


測試後確實發現有這個bug…,不重要,無視

會拆那麼多份,是因為以前舊版excel,這樣寫可以增加一點點效率、穩定性
所以副程式才會取名為 fake_Multiplex => 假多工

改版後的yahoo,json資料為主,不用這樣寫了,穩定性也相當好
fake_Multiplex()
可以改成這樣,從第一筆跑到最後一筆就行,程式碼也比較短
不用拆的亂七八糟,百分比數字跳的也比較好看
有興趣可以自行替換

Sub fake_Multiplex()

Dim i As Integer, LastRow As Integer, t As Double
t = Timer
DownloadError = 0
LastRow = Sheets("stock").Range("a1").CurrentRegion.Rows.Count
Sheets("stock").Range("b2:l" & LastRow).Clear: Sheets("stock").Range("n1:n3") = ""

For i = 2 To LastRow
DoEvents
Sheets("stock").Range("n1") = "Loading " & Round((i / LastRow) * 100) & "%"
Call getstock(i, i)
Next i

With Sheets("stock")
If DownloadError > 0 Then Call Redownload
If DownloadError > 0 Then .Range("n2") = DownloadError & " 下載失敗"
.Range("n1") = LastRow - 1 - DownloadError & " stock loading ok"
.Cells.EntireColumn.AutoFit
End With

Debug.Print Timer - t

End Sub
nijawang

謝謝snare大的分享!

2021-09-19 22:36
樓主您好:
有關Yahoo股利分配查詢的頁面已完全改版,使用您提供的新版股票查詢程式,並自行修改部分程式碼,作為股利查詢,但執行過程,一直出現錯誤訊息,實在解決不了,上線請樓主撥空看看,應如何修正?

部分程式碼:
DoEvents
URL = "https://tw.stock.yahoo.com/d/s/dividend_6206.html"
Set GetXml = CreateObject("WinHttp.WinHttpRequest.5.1")
Set Jsondata = CreateObject("HtmlFile")


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
dtemp = "{""QuoteDividendStore"":{""dividend"":{""data"":[" & Split(Split(.responsetext, """QuoteDividendStore"":{""dividend"":{""data"":[")(1), ",""WaferMarketTimeStore"":")(0)

Set DecodeJson = CallByName(CallByName(Jsondata.JsonParse(dtemp), "dividend", VbGet), "data", VbGet)
Debug.Print dtemp

錯誤訊息:

activer wrote:
有關Yahoo股利分配查詢的頁面已完全改版,使用您提供的新版股票查詢程式


前幾個月,因為yahoo瘋狂改版,做了很多沒po的範例
剛好其中一個clipboard版的範例就是這個,先參考這個...
(您json下載錯誤修正方式,請看文末的補充說明後,再自行修正)

Sub Get_Yahoo_dividend_clipboard()

Dim html As Object, Table, Clipboard As Object, xmlHttp As Object, URL As String, Original_Data As Range, LastRow As Integer, Stock As String, ttt As Double
Set Clipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
Set html = CreateObject("htmlfile")

ttt = Timer

'Stock = "2412" 'test
Stock = "2002" 'test
'Stock = "2330" 'test

URL = "https://tw.stock.yahoo.com/quote/" & Stock & "/dividend"

Set xmlHttp = CreateObject("WinHttp.WinHttpRequest.5.1")

With xmlHttp

.Open "GET", URL, False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.setRequestHeader "Cache-Control", "no-cache"
.setRequestHeader "Pragma", "no-cache"
.send




End With


Set Table = html.getElementById("main-2-QuoteDividend-Proxy")
Clipboard.SetText Table.innerText
Clipboard.PutInClipboard

Application.ScreenUpdating = False

With Sheets("工作表1")
.Select
.Cells.Clear
.Cells(1, 1).Select
.PasteSpecial NoHTMLFormatting:=False
.Range("a1:a5").Delete Shift:=xlUp

Set Original_Data = .Range("a3")
LastRow = 2 '0 to n
Do Until Original_Data.Value = ""
LastRow = LastRow + 1
Original_Data.Resize(6).Copy
.Range("B" & LastRow).PasteSpecial Transpose:=True
Set Original_Data = Original_Data.Offset(6)
Loop
.Range("b1:b2").Value = .Range("a1:a2").Value
.Range("b1").Value = "(" & Stock & ")" & .Range("b1").Value
.Columns("A:A").Delete Shift:=xlToLeft
.Cells.ColumnWidth = 16

End With

Debug.Print Timer - ttt

Application.ScreenUpdating = True

Set xmlHttp = Nothing
Set Clipboard = Nothing
Set Table = Nothing
Set html = Nothing

End Sub





activer wrote:
但執行過程,一直出現錯誤訊息


會錯誤是因為,json沒有做成正確格式


temp = "{""QuoteDividendStore"":{""dividend"":{""data"":[" & Split(Split(.responsetext, """QuoteDividendStore"":{""dividend"":{""data"":[")(1), ",""WaferMarketTimeStore"":")(0) & "}"

Set DecodeJson = CallByName(CallByName(CallByName(Jsondata.JsonParse(temp), "QuoteDividendStore", VbGet), "dividend", VbGet), "data", VbGet)


'接下來就一層一層拆出想要的資料
'最近可參考的json拆解範例是1053樓
For i = 0 To CallByName(DecodeJson, "length", VbGet) - 1
set ...
....
....

Next i

  • 114
評分
複製連結
請輸入您要前往的頁數(1 ~ 114)