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

wujjjj
個人積分：0分
文章編號：91414341

0分

1551樓

2025-04-13 9:05

請問版主：

剛看了您的文章，好強，好像什麼都能抓，在此跟您請教一個問題，
https://mops.twse.com.tw/mops/#/web/t163sb04
公開資訊觀測站=>匯總報表=>財務報表=>綜合損益表，改版後無法抓取，程式碼該如何修改解決?

我的程式碼如下：

Set HTMLcode = CreateObject("htmlfile")
Set HttpReq = CreateObject("msxml2.xmlhttp")
URL = "https://mops.twse.com.tw/mops/web/ajax_t163sb04"

For i = 1 To Sdowntime

Application.StatusBar = GetProgress("損益表下載", i, Sdowntime)
Y = Sheets("新損益表").Cells(1, firstSeasonColumn + i - 1) - 1911
Q = Sheets("新損益表").Cells(2, firstSeasonColumn + i - 1)

With Sheets("暫存")

For k = 1 To 2 ' sii、otc共兩次

If k = 1 Then
TYPEK = "sii" '上市
Else
TYPEK = "otc" '上櫃
End If

.Cells.Clear
Call waitSecond(1)

With HttpReq
.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"
'.Send "encodeURIComponent=1&step=1&firstin=1&off=1&TYPEK=" & sii & "&year=" & Y & "&season=" & Q
.Send "encodeURIComponent=1&step=1&firstin=1&off=1&isQuery=Y&TYPEK=" & TYPEK & "&year=" & Y & "&season=0" & Q
'encodeURIComponent=1&step=1&firstin=1&off=1&isQuery=Y&TYPEK=sii&year=106&season=01'上市
'encodeURIComponent=1&step=1&firstin=1&off=1&isQuery=Y&TYPEK=otc&year=106&season=01'上櫃

Do Until .readyState = 4: DoEvents: Loop
HTMLcode.Body[removed] = .ResponseText
End With

lastrow = 0
For TableCnt = 1 To HTMLcode.all.tags("table").Length - 1 '從1開始，去標頭
Set Table = HTMLcode.all.tags("table")(TableCnt).Rows
For s = 0 To Table.Length - 1
For t = 0 To Table(s).Cells.Length - 1
.Cells(s + 1 + lastrow, t + 1) = Table(s).Cells(t).innerText
Next
Next
lastrow = lastrow + s + 3
Next

snare

snare
個人積分：3046分
文章編號：91414816

3046分

樓主

2025-04-13 11:17

wujjjj wrote:
公開資訊觀測站=>匯總報表=>財務報表=>綜合損益表，改版後無法抓取，程式碼該如何修改解決?

[點擊下載]

bigiuan

bigiuan
個人積分：0分
文章編號：91491263

0分

1553樓

2025-04-28 22:42

請問版大，最近的股票更新出現問題，之前沒有問題的，可否勞煩您幫忙檢查，謝謝您

Sub WebQuery_HIS_STOCK_PRICE(sDate)

Dim URL As String

With Sheets("股價網路更新") '到哪個工作表
.Visible = True
.Range("A1:P10000").ClearContents '清除位置
'.Activate
End With

'上市外資投信1 URL = "https://www.twse.com.tw/rwd/zh/fund/T86?date=" & sDate & "&selectType=ALLBUT0999&response=html"
'上市盤後定價交易1 URL = "https://www.twse.com.tw/rwd/zh/afterTrading/BFT41U?date=" & sDate & "&selectType=ALLBUT0999&response=html"
'上市每日收盤行情9+上市類股指數1
URL = "https://www.twse.com.tw/rwd/zh/afterTrading/MI_INDEX?date=" & sDate & "&type=ALLBUT0999&response=html"

With Sheets("股價網路更新").QueryTables.Add(Connection:="URL;" & URL, Destination:=Sheets("股價網路更新").Range("A1"))
'上面也要改
.Name = "HIS_STOCK_PRICE"
.PostText = thePOST
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = False
.AdjustColumnWidth = False
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "9" '僅抓第1個表格
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = True '關閉日期辨識
.Refresh BackgroundQuery:=False
.Delete
End With

snare 樓主

請參考1306樓。

2025-04-29 7:57

bigiuan

謝謝樓主，但您的意思我不太懂，是要改變寫法嗎?

2025-04-29 16:15

snare

snare
個人積分：3046分
文章編號：91497073

3046分

樓主

2025-04-30 6:24

bigiuan wrote:
最近的股票更新出現問題，之前沒有問題的，可否勞煩您幫忙檢查

也許是您的excel出問題，把程式碼貼到新檔案試試
或是twse剛好在更新資料、表格換位置
我剛才試是正常的

點我看大圖

bigiuan wrote:
謝謝樓主，但您的意思我不太懂，是要改變寫法嗎?

如果您願意，可試試不同方式，QueryTables限制比較多，不是table格式就抓不到
twse 正在慢慢更新網頁，像是1552樓
以後QueryTables就不能用了，不然就只能重新學習Power Query

1306樓是json寫法

html table寫法如下

Sub GET_TWSE_afterTrading_html()
    
    Dim GetXML As Object, HTML As Object, URL As String, i As Double, j As Integer

    Set HTML = CreateObject("htmlfile")
    Set GetXML = CreateObject("msxml2.xmlhttp")


    URL = "https://www.twse.com.tw/rwd/zh/afterTrading/MI_INDEX?date=20250428&type=ALL&response=html"
    
    Application.ScreenUpdating = False
    Sheets("工作表1").Cells.Clear
    Sheets("工作表1").Columns("A:A").NumberFormatLocal = "@"
    
    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"
        .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64; rv:128.0) Gecko/20100101 Firefox/128.0"
        .send
        
        HTML.body.innerhtml = .responsetext
        

    End With
    
     
        
    Set Table = HTML.all.tags("table")(8).Rows
        
    For i = 0 To Table.Length - 1
        For j = 0 To Table(i).Cells.Length - 1
            Sheets("工作表1").Cells(i + 1, j + 1) = Table(i).Cells(j).innertext
        Next j
    Next i
            
            
        
    Application.ScreenUpdating = True
    'Sheets("工作表1").Columns.AutoFit
    Set HTML = Nothing
    Set GetXML = Nothing
   
    
End Sub

bigiuan

謝謝版主熱心回答，目前發現我的excel連不上www.twse.com.tw，但其他網站都可以，重灌excel也不行，或許是我excel或windows的問題吧。

2025-04-30 22:26

bank87012

bank87012
個人積分：0分
文章編號：91643014

0分

1555樓

2025-05-31 0:57

已找出詳細資料路徑但不知如何編碼程式碼

snare

snare
個人積分：3046分
文章編號：91651033

3046分

樓主

2025-06-02 11:30

bank87012 wrote:
已找出詳細資料路徑但不知如何編碼程式碼

至於如何下載詳資料網址內的資料，使用普通的html table寫法就行
例如：1554樓，table 0~3 ，請自行練習
(另外，您發問，最重要網址沒給，會增加不少我回答的時間)

[點擊下載]

野比大雄1

野比大雄1
個人積分：0分
文章編號：91733374

0分

1557樓

2025-06-19 18:44

您好想請問版主下面是我原始程式碼
但是現在網站又改了我改了網址抓不到資料謝謝

新版網址:https://tw.stock.yahoo.com/future/WTX&

Sub Get_Yahoo_Wtx_Json()

Dim xmlhttp As Object, Jsondata As Object, url As String, DecodeJson, Mem, Tick, i As Integer, j As Integer
On Error Resume Next

Set xmlhttp = CreateObject("msxml2.xmlhttp")
Set Jsondata = CreateObject("HtmlFile")
Jsondata.write ""

Application.ScreenUpdating = False
Sheets("stock").Range("B2:L2").Clear

url = "https://tw.stock.yahoo.com/future/WTX&" '一
' UrL = "https://tw.screener.finance.yahoo.net/future/q?type=tick&perd=1m&mkt=01&sym=WTX%40" '二

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

Set DecodeJson = Jsondata.JsonParse(Replace(Replace(.responseText, "null(", ""), ");", ""))
Set Mem = CallByName(DecodeJson, "mem", VbGet)
Set Tick = CallByName(DecodeJson, "tick", VbGet)

' For i = 1 To CallByName(Tick, "length", VbGet)
'
' Set temp = CallByName(Tick, i - 1, VbGet)
'
' Sheets("工作表1").Cells(i + 1, 1) = "'" & CallByName(temp, "t", VbGet)
' Sheets("工作表1").Cells(i + 1, 2) = CallByName(temp, "p", VbGet)
' Sheets("工作表1").Cells(i + 1, 3) = CallByName(temp, "v", VbGet)
'
' Next i
'Sheets("stock").Cells(2, 1) = "WTX"
Sheets("stock").Cells(2, 2) = "台指期"
Sheets("stock").Cells(2, 3) = CallByName(Mem, "TradeDay", VbGet)
Sheets("stock").Cells(2, 4) = CallByName(Mem, "125", VbGet)
Sheets("stock").Cells(2, 5) = CallByName(Mem, "183", VbGet)
Sheets("stock").Cells(2, 6) = CallByName(Mem, "182", VbGet)
Sheets("stock").Cells(2, 8) = CallByName(Mem, "404", VbGet)
Sheets("stock").Cells(2, 9) = CallByName(Mem, "129", VbGet)
Sheets("stock").Cells(2, 10) = CallByName(Mem, "126", VbGet)
Sheets("stock").Cells(2, 11) = CallByName(Mem, "130", VbGet)
Sheets("stock").Cells(2, 12) = CallByName(Mem, "131", VbGet)
Sheets("stock").Cells(2, 13) = CallByName(Mem, "184", VbGet)
Sheets("stock").Cells(2, 7) = WorksheetFunction.RoundUp(((Sheets("stock").Range("D2") - Sheets("stock").Range("I2")) / Sheets("stock").Range("I2")) * 100, 2) '漲跌幅計算'CallByName(Mem, "185", VbGet)
'Sheets("工作表1").Range("a1:c1") = Array("t", "p", "v")
'Sheets("工作表1").Cells(2, 4) = CallByName(Mem, "name", VbGet)
Sheets("stock").Columns.AutoFit

End With
With Sheets("stock")

If .Cells(2, 7) > 0 Then
.Cells(2, 7).Value = "▲" & .Cells(2, 7) & "%"
.Cells(2, 7).Font.Color = -16776961

ElseIf .Cells(2, 7) < 0 Then
.Cells(2, 7).Value = Replace(.Cells(2, 7), "-", "▼") & "%"
.Cells(2, 7).Font.Color = -11489280
End If
' s = Mid(.Cells(2, 7), 1, 5)
' .Cells(2, 7) = s & "%"

DD = Format(Time, "hh:mm:ss")
.Cells(2, 3) = DD
End With

Application.ScreenUpdating = True

Set xmlhttp = Nothing
Set Jsondata = Nothing
Set DecodeJson = Nothing
Set Mem = Nothing
Set Tick = Nothing
Set temp = Nothing

End Sub

snare

snare
個人積分：3046分
文章編號：91735580

3046分

樓主

2025-06-20 9:56

野比大雄1 wrote:
新版網址:https://tw.stock.yahoo.com/future/WTX&

這個網址內有9個json分類，我不知道您要裡面什麼資料
簡易寫法如下：

點我看大圖

[點擊下載]

野比大雄1

好的謝謝

2025-06-30 18:21

oliwa

oliwa
個人積分：1分
文章編號：91983165

1分

1559樓

2025-08-09 21:55

版大 , https://hk.finance.yahoo.com/quote/600519.SS/history/?period1=1735745316&period2=1767139200&interval=1mo&filter=history&frequency=1mo ,
近期改版資料無法下載 , 請版大協助 , tks .
( period1 , 2 不用處理 , 比對後同一時間內值相同 , 另設參數套用了 )

oliwa

版大 , 請先不用處理這問題 ; 剛發問完帖 , 再去修改參數 , 突然就能順利轉出表格資料了 , 大概自己參數一直選錯了 , 謝謝 !!

2025-08-09 22:14