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

g80860

8分

1361樓

g80860

個人積分：8分

文章編號：88806819

請問版主:
有關>>下載網時有流量限制次數限制,有沒有可以寫入vba處理或延緩幾秒再處理等方式,不用另裝軟體,直接在vba 寫入,下載慢點也可以.請教有這樣vba寫法嗎??謝謝.

nijawang

1231分

1362樓

nijawang

個人積分：1231分

文章編號：88808826

請問snare大，
昨天Yahoo Stock改版，有些值放到了下一層
不知道我該怎麼取出這些值？
我之前都是用CallByName(DecodeJson, "ask", VbGet)
點我看大圖

謝謝！

蔬食抗暖化，減碳救地球！

nijawang

已自行解決，回在下一樓〜

2023-12-15 14:27

yth0315

10分

1363樓

yth0315

個人積分：10分

文章編號：88809386

snare大,
Yahoo股市又改code了~~ 請問兩年前您給我的程式該修改哪裡?
請原諒我對Json真的不懂, 謝謝!
-------------------------------------------------------------------------------
Sub Get_Yahoo_類股報價_Json()

Dim Xmlhttp As Object, Jsondata As Object, DecodeJson, Url As String, sectorId As String, exchange As String, p As Integer, Page As Integer, temp, i As Integer, ttt As Double

Sheets("工作表1").Cells.Clear
Sheets("工作表1").Range("a1:k1") = Array("股票名稱", "代號", "股價", "漲跌", "漲跌幅(%)", "開盤", "昨收", "最高", "最低", "成交量 (張)", "時間")
Application.ScreenUpdating = False

'sectorld、exchange，2個參數，同開啟網頁時，網址上的參數
'test
sectorId = "4"
exchange = "TAI"

'test
'sectorId = "33"
'exchange = "TAI"

'test
'sectorId = "123"
'exchange = "TWO"

'test
'sectorId = "167"
'exchange = "TWO"

'test
'sectorId = "166"
'exchange = "TWO"

ttt = Timer

Page = 1
p = 0

Do

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

'因語法關係無法正常顯示，Jsondata.write 這行程式碼，請手動輸入

Url = "https://tw.stock.yahoo.com/_td-stock/api/resource/StockServices.getClassQuotes;exchange=" & exchange & ";offset=" & p * 30 & ";sectorId=" & sectorId & "?bkt=tw-qsp-exp-no2-1&device=desktop&ecma=default&feature=ecmaModern&intl=tw⟪=zh-Hant-TW&partner=none®ion=TW&site=finance&tz=Asia/Taipei&returnMeta=true"

With Xmlhttp

.Open "GET", 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"
.send

End With

Set DecodeJson = CallByName(Jsondata.JsonParse(Xmlhttp.responsetext), "data", VbGet)

If p = 0 Then

Page = CallByName(CallByName(DecodeJson, "pagination", VbGet), "resultsTotal", VbGet)
Debug.Print Page 'total
If Page = 0 Then
MsgBox "暫無資料", vbOKOnly, "Error"
Application.ScreenUpdating = True
Exit Sub
End If

Page = WorksheetFunction.RoundUp(Page / 30, 0)

End If

With Sheets("工作表1")

For i = 0 To CallByName(CallByName(DecodeJson, "list", VbGet), "length", VbGet) - 1
Set temp = CallByName(CallByName(DecodeJson, "list", VbGet), i, VbGet)

.Cells(i + 2 + (p * 30), 1) = temp.symbolName
.Cells(i + 2 + (p * 30), 2) = CallByName(temp, "symbol", VbGet)
.Cells(i + 2 + (p * 30), 3) = CallByName(temp, "price", VbGet)
.Cells(i + 2 + (p * 30), 4) = CallByName(temp, "change", VbGet)
.Cells(i + 2 + (p * 30), 5) = "'" & temp.changePercent
.Cells(i + 2 + (p * 30), 6) = temp.regularMarketOpen
.Cells(i + 2 + (p * 30), 7) = temp.regularMarketPreviousClose
.Cells(i + 2 + (p * 30), 8) = temp.regularMarketDayHigh
.Cells(i + 2 + (p * 30), 9) = temp.regularMarketDayLow
.Cells(i + 2 + (p * 30), 10) = temp.volumeK
.Cells(i + 2 + (p * 30), 11) = temp.regularMarketTime

Next i

End With

Set Xmlhttp = Nothing
Set Jsondata = Nothing
Set DecodeJson = Nothing
Set temp = Nothing

p = p + 1

'Delaytick(0.5)

Loop Until p = Page

Sheets("工作表1").Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True
Debug.Print Timer - ttt & "s"

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
------------------------------------------------------------------------------------------------------------

snare wrote:
1024樓

從...(恕刪)

nijawang

1231分

1364樓

nijawang

個人積分：1231分

文章編號：88809543

yth0315 wrote:
snare 大，
Yahoo 股市又改 code 了～～請問兩年前您給我的程式該修改哪裡？
請原諒我對 Json 真的不懂，謝謝！

自回我的問題，順便回覆您的問題〜
有幾個地方因為Yahoo多加了一層，所以我們要再多用一層CallByName()來抓。

像是
.Cells(i + 2 + (p * 30), 3) = CallByName(CallByName(temp, "price", VbGet), "raw", VbGet)

其它如
price, bid, ask, change, regularMarketOpen, regularMarketDayHigh, regularMarketDayLow, regularMarketPreviousClose
也都要再多加一層CallByName()

蔬食抗暖化，減碳救地球！

yth0315

感謝nijawang大, 已經遵照教導改好了! 謝謝! 謝謝!

2023-12-17 18:37

bigbirdbear

謝謝忍者大指點,已經可以正常run

2023-12-25 22:00

野比大雄1

0分

1365樓

野比大雄1

個人積分：0分

文章編號：88809919

您好:
想請問這怎麼改,我是用之前的程式碼，謝謝

圖片

點我看大圖

原始程式碼

Sub fake_Multiplex()

Call Get_Yahoo_Wtx_Json
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("b3:l" & LastRow).Clear: Sheets("stock").Range("n1:n3") = ""

For i = 3 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

Sheets("股票").Select
'Call EX_停損停利通知

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, changePercent As Double

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")

Jsondata.write ""

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)
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
'==============================

'==============================
'二、漲跌，使用▲▼
'debug.print vartype(CallByName(DecodeJson, "changePercent", VbGet)) ' 8 = string
.Cells(k, 7) = CallByName(DecodeJson, "changePercent", VbGet)
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
'==============================

.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

野比大雄1

cji3cj6xu6 謝謝已正常使用,感謝協助

2023-12-15 16:09

callin00

感謝nijawang，還有這裏幾位大大即時的相救^^

2023-12-15 17:03

cji3cj6xu6

0分

1366樓

cji3cj6xu6

個人積分：0分

文章編號：88813773

snare wrote:
字串格式的索引，有點...(恕刪)

謝謝Snare大，我終於找到了先前您在 "1157F" 對於層層剝開的詳細說明。

snare

3127分

樓主

snare

個人積分：3127分

文章編號：88821349

nijawang wrote:
有幾個地方因為Yahoo多加了一層，所以我們要再多用一層CallByName()來抓

感謝你幫忙找問題

最後一層的名稱，如果不會和vba語法衝突，可用另一種寫法
CallByName(CallByName(temp, "price", VbGet), "raw", VbGet)

CallByName(temp, "price", VbGet).raw

cji3cj6xu6 wrote:
"1157F" 對於層層剝開的詳細說明

如果無法用.length取得長度，或是最後一層沒有名稱可用
進階一點的方式
可參考(1168、1171、1281、1282)樓

g80860 wrote:
有沒有可以寫入vba處理或延緩幾秒再處理等方式,不用另裝軟體,直接在vba 寫入,下載慢點也可以.請教有這樣vba寫法嗎??

可用 Application.OnTime Now，延後副程式執行

或在迴圈中加入延遲


Sub test()

    For t = 1 To 10
    
        Delaytick (1)  '秒數
        
        Debug.Print t
    
    Next t

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