https://www.tpex.org.tw/www/zh-tw/afterTrading/tradingStock?code=3455&date=2023%2F10%2F01&id=&response=html
Sub Ex_上櫃股票收盤價及月平均收盤價()
'程式碼來源: http://forum.twbts.com/viewthread.php?tid=20381
Application.ScreenUpdating = False
Dim oXmlhttp As Object, oHtmldoc As Object, surl, i, E, r As Double, C As Double
Dim StockNo As String, xday As String, xRow As Integer, Day1 As Date, Day2 As Date, xTime As Date
Sheets("主畫面").Select
StockNo = [A2]
Day1 = ActiveSheet.[B2]
Day2 = ActiveSheet.[C2]
Sheet4.Cells.Clear '清除下載記錄
If DateDiff("m", Day1, Day2) > 24 Then
MsgBox "查詢區間請以2年內為主"
Exit Sub
End If
For i = 0 To DateDiff("m", Day1, Day2)
xday = Format(DateAdd("m", i, Day1), "yyyy") - 1911 & "/" & Format(DateAdd("m", i, Day1), "mm")
Set oXmlhttp = CreateObject("msxml2.xmlhttp")
Set oHtmldoc = CreateObject("htmlfile")
surl = "https://www.tpex.org.tw/web/stock/aftertrading/daily_trading_info/st43_print.php?l=zh-tw&d=" & xday & "&stkno=" & StockNo & "&s=0,asc,0" & StockNo
With oXmlhttp
Sheet4.Cells(1, 1).Offset(i, 0).Value = surl
.Open "Get", surl, False
.send
If InStr(.responsetext, "很抱歉，沒有符合條件的資料!") Then
MsgBox "很抱歉，沒有符合條件的資料!" & vbLf & "請檢查 股票代號"
Exit Sub
ElseIf InStr(.responsetext, "查詢日期小於88年1月5日，請重新查詢") Then
MsgBox "查詢日期小於88年1月5日!" & vbLf & "請檢查 起始日期"
Exit Sub
ElseIf InStr(.responsetext, "查詢日期大於今日，請重新查詢") Then
MsgBox "查詢日期大於今日" & vbLf & "請檢查 終止日期"
Exit Sub
End If
oHtmldoc.write .responsetext
End With
With oHtmldoc
Set E = .all.tags("table")(0)
With ActiveSheet
If i = 0 Then .Range("a3:I" & Rows.Count).Clear
xRow = .Cells(Rows.Count, "a").End(xlUp).Row + IIf(i = 0, 1, 0)
For r = IIf(i = 0, 0, 2) To E.Rows.Length - 2 'By 彰化一整天20200309沒有月平均了，原-2改成-1
For C = 0 To E.Rows(r).Cells.Length - 1
.Cells(xRow + r + IIf(i > 0, -1, 0), C + 1) = E.Rows(r).Cells(C).innertext
Next
Next
End With
End With
Set oXmlhttp = Nothing
Set oHtmldoc = Nothing
Application.StatusBar = "**** " & Format(DateAdd("m", i, Day1), "ee/mm") & " " & i & "/" & DateDiff("m", Day1, Day2) & " 載完畢 *****"
'**** 股市營業時間有流量管制 **
'xTime = Time + #12:00:09 AM# '間隔 10秒
'Do : DoEvents: Loop Until Time > xTime
'**********或是下式**********************
'Application.Wait Now + #12:00:09 AM#
'********************************
Dim newHour, newMinute, newSecond, waitTime
If i Mod 6 = 5 Then '每6個月間隔5秒
newHour = Hour(Now())
newMinute = Minute(Now())
newSecond = Second(Now()) + 5
waitTime = TimeSerial(newHour, newMinute, newSecond)
Application.Wait waitTime
End If
Next
'MsgBox "ok"
Application.ScreenUpdating = True
End Sub
snare wrote:謝謝snare大還幫我測試這麼多！
您不是在 1491 樓就問過？
我測試那個範例是正常的
抓History倒是都很正常，沒問題。
是用VBA抓到的網頁即時Json資料有些會錯亂。
原本也想說是不是自己的電腦問題？
不過試了二台也都一樣問題，也用了不同的VBA，也是會錯亂。
就是我上傳的那個VBA抓到的Json，有些抓錯資料、有些抓不到、有些只抓到舊資料…
照理說網頁上的資料應該是最新的資料才是。
我之前是在146頁-1454樓有詢問過
那時也發生過類似的問題，只是好像兩天就變正常了；
只是這次快一個月了還是會有資料錯亂的問題。
想說是不是我的VBA寫法有bug，不過也不是全部都有問題。
感謝snare大！
nijawang wrote:
想說是不是我的VBA寫法有bug，不過也不是全部都有問題。
即時資料的寫法，大概是這樣
[點擊下載]
近期要撈上櫃個股月成交資訊好像因為改版的關係而無法下載，
重新修改網址也無法正常下載
是否能協助小弟我，謝謝您!
提供我的code:
'*************************************
' 擷取「上櫃」股票的「個股月成交資訊」
'*************************************
Sub TPEX_PRICE_MONTH(theTicker)
'指定個股月成交資訊轉寫工作表
Set theSheet = Worksheets("PRICE_M")
'指定Excel QueryTable查詢結果轉寫的起始儲存格
Set theCell = theSheet.Range("C1")
'先將PRICE_M設為作用工作表，並刪除目前工作表中的所有內容
With theSheet
.Activate
.Cells.ClearContents
End With
For yyyy = Year(Date) - 8 To Year(Date)
'表單傳送目的網址
theURL = "https://www.tpex.org.tw/web/stock/statistics/monthly/result_st44.php?l=zh-tw"
'HTML表單(FORM)採用POST傳遞參數與值(內容)
thePOST = "ajax=true&l=zh-tw&input_stock_code=" & theTicker & "&yy=" & yyyy
'狀態列顯示目前作業內容
Application.StatusBar = "擷取上櫃股票[" & theTicker & "] " & yyyy & "年的個股月成交資訊..."
With theSheet.QueryTables.Add(Connection:="URL;" & theURL, Destination:=theCell)
.Name = "st44"
.PostText = thePOST 'POST傳遞參數與值(內容)
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlOverwriteCells
.AdjustColumnWidth = False
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "1,3"
.WebDisableDateRecognition = True
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
.Delete '取得個股年度成資訊後刪除本QueryTable
End With
'Set theCell = theSheet.Cells(Rows.Count, "C").End(xlUp) <= 修正前
Set theCell = theSheet.Cells(Rows.Count, "C").End(xlUp).Offset(1) '<= 修正後
Next yyyy
'清除狀態列內容
Application.StatusBar = False
End Sub
snare wrote:再次感謝snare大的回覆！
即時資料的寫法，大概是這樣
即時資料試起來是正常。
不過我是想也抓一些網頁沒顯示的資料。
這是我之前正常的VBA(部份)，那時您也有幫忙修正過。
---------------------------------------------------------------------------
Dim GetXml, Jsondata As Object
Dim UrL, stock As String
UrL = "https://finance.yahoo.com/quote/BNDW"
DoEvents
Set GetXml = CreateObject("msxml2.xmlhttp")
Set Jsondata = CreateObject("HtmlFile")
Jsondata.write ""
With GetXml
.Open "GET", UrL, False
.send
temp = Split(.responsetext, """body"":""{\""quoteResponse\"":")
temp1 = Replace(Split(temp(1), "}""}")(0), "\", "")
temp = Split(.responsetext, """body"":""{\""quoteSummary\"":")
temp2 = Replace(Split(temp(1), "}""}")(0), "\", "")
temp2 = Replace(temp2, "(the ""securities"")", "(the securities)")
Set DecodeJson1 = CallByName(CallByName(Jsondata.JsonParse(temp1), "result", VbGet), "0", VbGet)
Set DecodeJson2 = CallByName(CallByName(Jsondata.JsonParse(temp2), "result", VbGet), "0", VbGet)
End With
---------------------------------------------------------------------------
因為有些ETF真的會抓錯或抓不到資料，所以再查了一下，現在好像又有crumb了…
所以我把Url改為：
UrL = "https://query1.finance.yahoo.com/v7/finance/quote?&symbols=BNDW&crumb=pSrkoZe2q5v&formatted=false®ion=US&lang=en-US"
但在Edge中可以讀到資料；而在Chrome中卻說沒有權限？
{
"finance": {
"result": null,
"error": {
"code": "Unauthorized",
"description": "User is unable to access this feature - https://bit.ly/yahoo-finance-api-feedback"
}
}
}
而在Excel中就都讀不到資料。
目前還在VBA錯誤中掙扎…
nijawang wrote:
不過我是想也抓一些網頁沒顯示的資料。
在json裡面，但沒列出來?
以下範例是把網頁內，跟json有關的文字，全拆出來
大部份可以正常轉成json物件。每列為1組，例：Jsondata.JsonParse(range("a1"))
但部份資料格式要修正才能轉
如果只是要部份資料
建議用split、mid、insrt、left、right…等等文字函數處理，會比較簡單
Sub Get_JsonText_Only()
Dim Reg As Object, xmlhttp as object,JsonTextMatch, JsonText, r As Integer
Set xmlhttp = CreateObject("MSXML2.XMLHTTP")
Set Reg = CreateObject("VBScript.RegExp")
Sheets("工作表1").Cells.Clear
Url = "https://finance.yahoo.com/quote/BNDW/"
xmlhttp.Open "GET", Url, False
xmlhttp.send
Reg.IgnoreCase = True
Reg.Pattern = "\[{(.*?\}])"
Reg.Global = True
Set JsonTextMatch = Reg.Execute(Replace(xmlhttp.ResponseText, "\", ""))
For Each JsonText In JsonTextMatch
r = r + 1
'If InStr(JsonText.Value, "要查的字串") > 0 Then
'網頁這個json字串，有需要的資料
'split、mid or other function…
'End If
'debug
Sheets("工作表1").Cells(r, 1) = JsonText.Value
Next
set reg=nothing
set xmlhttp=nothing
End Sub
內文搜尋
從 APP 打開
X