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

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

3046分

樓主

2024-11-15 11:32

f006116 wrote:
1.以我原本寫法方式的URL改法建議? →1526樓
2.以目前S大寫法(單一年份)若改為抓取多年分(如下圖呈現方式)的寫法建議?

1、改2行
theURL = "https://www.tpex.org.tw/www/zh-tw/statistics/monthlyStock?"
thePOST = "date=" & yyyy & "&code=" & theTicker & "&id=&response=html"

2、架構同您的程式，一樣是用迴圈改網址，最後再修正排版

f006116

真的非常感謝S大的幫忙! 我也連同"上櫃個股年成交資訊"的部分都一起修正完成了，剛剛測試可以正常運作了!非常感謝!!向您在版上長年無私的付出與協助致敬!!

2024-11-15 14:13

nijawang

nijawang
個人積分：1231分
文章編號：90664920

1231分

1532樓

2024-11-19 21:14

nijawang wrote:再次感謝 snare 大的回覆！
即時資料試起來是正常。
不過我是想也抓一些網頁沒顯示的資料。

這是我之前正常的 VBA (部份)，那時您也有幫忙修正過。

晚上再試了一下原本有問題的VBA，竟然全部都變成正常了！！
看來還真的是Yahoo!Finance網頁的問題。
只是這一次工程師花了比較長的時間才發現並修正〜

peter624

peter624
個人積分：5分
文章編號：90685420

5分

1533樓

2024-11-23 0:18

snare哥你好

近期不曉得是否因為tpex改版，無法下載https://www.tpex.org.tw/zh-tw/mainboard/trading/statistics/month/summary.html的xls檔案，執行到Set DecodeJson = Jsondata.JsonParse(.responsetext) 就有error，不曉得是否可協助幫忙，萬分感謝。

'取得下載網址範例
Sub Get_tpex()

Dim Xmlhttp As Object, Jsondata As Object, DecodeJson, temp
Dim Url As String, Url_a As String, Url_b As String, sd As String, ed As String, i As Integer
Dim tempAddress1()
Dim Year As String
Dim Month As String
Dim canDownload As Boolean
Dim DateArr() As String

Set Jsondata = CreateObject("HtmlFile")
Jsondata.Write ""

Application.ScreenUpdating = False

canDownload = False

ReDim tempAddress1(1000, 1)

Year = Worksheets("歷年營收").ComboBox5.Value
Month = Worksheets("歷年營收").ComboBox3.Value

If Month < 10 Then Month = "0" & Month

sd = "99/02"
ed = Year - 1911 & "/" & Month

Target = "E:\123\每月最高最低股價\" & YearDir & "\" '暫存目錄

Url = "https://www.tpex.org.tw/zh-tw/mainboard/trading/statistics/month/summary.html"
Url_a = "https://www.tpex.org.tw/web/stock/statistics/monthly/monthly_rpt_mkt_info_05.php?l=zh-tw"
Url_b = "https://www.tpex.org.tw/web/stock/statistics/monthly/monthly_rpt_mkt_info_dl.php?DOC_ID="

Set Xmlhttp = CreateObject("Msxml2.XMLHTTP")

With Xmlhttp

.Open "GET", Url & UNIXTime, False
.setRequestHeader "Referer", Url_a
.setRequestHeader "sec-ch-ua-platform", "Windows"
.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/95.0.4638.69 Safari/537.36"
.send

Set DecodeJson = Jsondata.JsonParse(.responsetext)
Set temp = CallByName(DecodeJson, "aaData", VbGet)

Debug.Print temp

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

tempAddress1(i, 0) = CallByName(CallByName(temp, i, VbGet), "0", VbGet) ''日期 110/11
tempAddress1(i, 1) = Url_b & CallByName(CallByName(CallByName(temp, i, VbGet), "1", VbGet), "id", VbGet) ''DOC_ID
''tempAddress1(i, 1) = Url_b & CallByName(CallByName(temp, i, VbGet), "1", VbGet)

DateArr = Split(tempAddress1(i, 0), "/")

If DateArr(0) = Year - 1911 And DateArr(1) = Month Then
Url = tempAddress1(i, 1)

''URLDownloadToFile 0, Url, Target & YearDir & monthDir & "_C02005.zip", 0, 0
canDownload = True
Exit For
End If

''Cells(i + 1, 1) = CallByName(CallByName(temp, i, VbGet), "0", VbGet)
''Cells(i + 1, 2) = Url_b & CallByName(CallByName(temp, i, VbGet), "1", VbGet)
Next i

End With

If canDownload = True Then

''Url = "https://www.tpex.org.tw/web/stock/statistics/monthly/monthly_rpt_mkt_info_dl.php?DOC_ID=2360"

Call 下載上櫃每月最高最低股價CSV(Url, DateArr(0), DateArr(1))

End If

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

End Sub

snare

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

3046分

樓主

2024-11-23 6:37

peter624 wrote:
近期不曉得是否因為tpex改版

[點擊下載]

peter624

謝謝 snare哥幫忙解答

2024-11-23 7:54

bank87012

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

0分

1535樓

2024-12-09 23:47

遇到更名公司就無法正確執行相關異常訊息如圖片,另外大大可以教學詳細資料超連結如何網頁查找嗎?

Sub Get_twse_歷史重大訊息_link()

Dim HTML As Object, Getxml As Object, table As Object, i As Integer, j As Integer, url As String, Url_a As String, ttt As Double
Dim Ie_Open As Boolean, PostData As String, Yy As String, co_id As String, spoke_date As String, spoke_time As String, seq_no As String

Ie_Open = True '使用超連結，點擊插入註解，打開瀏覽器
'Ie_Open = False '使用文字格式網址，點擊插入註解，但不打開瀏覽器

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

Yy = "113"
co_id = "2883"
url = "https://mops.twse.com.tw/mops/web/ajax_t05st01"
Sheets("工作表1").Range("A3:F100").Clear
'Sheets("工作表1").Cells.Clear
Application.ScreenUpdating = False

ttt = Timer

With Getxml

.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"
.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
.send ("encodeURIComponent=1&step=1&firstin=1&off=1&keyword4=&code1=&TYPEK2=&checkbtn=&queryName=co_id&inpuType=co_id&TYPEK=all&co_id=" & co_id & "&year=" & Yy & "&month=&b_date=&e_date=")

HTML.body[removed] = .responseText

End With

Set table = HTML.all.tags("table")(1).Rows

For i = 0 To table.Length - 1
For j = 0 To table(i).Cells.Length - 1

Sheets("工作表1").Cells(i + 3, j + 1) = Trim(table(i).Cells(j).innerText)

If i > 0 And j = 5 Then
spoke_date = Split(Split(table(i).Cells(j)[removed], "spoke_date.value='")(1), "'")(0)
spoke_time = Split(Split(table(i).Cells(j)[removed], "spoke_time.value='")(1), "'")(0)
seq_no = Split(Split(table(i).Cells(j)[removed], "seq_no.value='")(1), "'")(0)
PostData = url & "?encodeURIComponent=1&firstin=true&b_date=&e_date=&TYPEK=sii&year=" & Yy & "&month=all&type=&co_id=" & co_id & "&spoke_date=" & spoke_date & "&spoke_time=" & spoke_time & "&seq_no=" & seq_no & "&MEETING_STEP=&MODEL=&ITEM=&e_month=all&step=2&off=1"

If Ie_Open = True Then
Sheets("工作表1").Hyperlinks.Add Sheets("工作表1").Cells(i + 3, j + 1), Address:=PostData, TextToDisplay:="詳細資料"
Else
Sheets("工作表1").Cells(i + 3, j + 1) = PostData
End If
End If

Next j
Next i

Sheets("工作表1").Columns.AutoFit
Sheets("工作表1").Rows.AutoFit

Application.ScreenUpdating = True

Set HTML = Nothing
Set Getxml = Nothing
Set table = Nothing

Debug.Print Timer - ttt & "s(download link)"

End Sub

snare 樓主

改1行， Set table = HTML.all.tags("table")(HTML.all.tags("table").Length - 1).Rows ，超連結在1325樓就回答過您了

2024-12-10 8:57

howard383873

howard383873
個人積分：0分
文章編號：90800384

0分

1536樓

2024-12-14 17:04

Snare大大您好，

近期發現公開資訊觀測站有新的版本，因此預計改抓該網站的資料，
但不確定以下程式是哪裡出錯，以致我一直抓不到資料，
不知道能否請Snare大大協助幫忙，十分感謝。
最後再感謝Snare大大這些年的付出，您的文章讓我受益良多，謝謝。

下方為網站連結：
https://mopsplus.twse.com.tw/mops/#/web/t05st03

Sub Stock_Information_Crawler()
Dim i As Integer
Dim j As Integer
Dim Position_1 As Integer
Dim Position_2 As Integer
Dim URL As String
Dim URL_Referer As String
Dim Xmlhttp As Object
Dim Jsondata As Object
Dim DecodeJson As Object

On Error Resume Next

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

Jsondata.write ""

URL = "https://mopsplus.twse.com.tw/mops/api/t05st03"
URL_Referer = "no-referrer"

Application.Wait Now + TimeValue("0:00:05")

With Xmlhttp
.Open "POST", URL, False
.setRequestHeader "Content-Type", "application/json"
.setRequestHeader "Referer", URL_Referer
.send "companyId", "1101"
End With

Cells(1, 1) = CallByName(DecodeJson, "enterpriseUnifiedNumber", VbGet)

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

snare

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

3046分

樓主

2024-12-15 7:59

howard383873 wrote:
以下程式是哪裡出錯

'…… 略 ……

   With Xmlhttp
        .Open "POST", URL, False
        .setRequestHeader "Content-Type", "application/json"
        .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64; rv:128.0) Gecko/20100101 Firefox/128.0"
        .send ("{""companyId"":""1101""}")
        
        Set DecodeJson = CallByName(Jsondata.JsonParse(.responsetext), "result", VbGet)

    End With

    Cells(1, 1) = CallByName(CallByName(DecodeJson, "enterpriseUnifiedNumber", VbGet), "value", VbGet)

'…… 略 ……

howard383873

已順利解決問題，謝謝Snare大大的回覆！

2024-12-16 21:38

alfidpan

alfidpan
個人積分：0分
文章編號：90958484

0分

1538樓

2025-01-14 18:06

S大您好
又來跟您請教，以下兩個網站的資料是不是有匯入EXCEL的可能性呢？
想把網頁內的內容匯入至EXCEL，自己試過都會出現Status為401的情況，
不知是不是網站有所防爬蟲的機制所造成，感謝您撥空回應。

https://www.wsj.com/market-data/quotes/company-list/country/argentina
https://www.marketwatch.com/tools/markets/stocks/country/argentina

snare

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

3046分

樓主

2025-01-15 6:52

alfidpan wrote:
https://www.wsj.com/market-data/quotes/company-list/country/argentina
https://www.marketwatch.com/tools/markets/stocks/country/argentina

程式碼同1487樓，換網址就行
防爬蟲有，但機制不明，好像沒什麼用
可多加一個if判斷有沒有資料

'Html.body... ... 略
        
If Html.all.tags("table").Length = 0 Then
        'try again
        Exit Sub
End If
        
'Set Table ... ... 略

alfidpan

感謝，再次仔細看您的範例，原來是Set GetXml = CreateObject("msxml2.xmlhttp")這裡不一樣，多打了.6.0就不一樣了，再次感謝您專業的解答。十分感謝您。

2025-01-15 19:29

nijawang

nijawang
個人積分：1231分
文章編號：90978112

1231分

1540樓

2025-01-18 15:01

snare大，
請問這種先要選幾個選項，才會出現資料的網頁該如何抓資料？
或是該從哪個地方下手？
謝謝！
點我看大圖

https://www.sitca.org.tw/ROC/Industry/IN2211.aspx?pid=IN2222_01