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

snare

snare
個人積分：3143分
文章編號：92232991

3143分

樓主

2025-10-03 16:01

ifye wrote:
目前chrome版本是141.0.7390.55
chrome driver版本是141.0.7390.54 (r1509326)
請問這裡driver應該是有相容chrome吧?

我測試是相容的
有時是網頁改版，程式碼無法正確下載，造成chromedriver錯誤

點我看大圖

'chrome 141.0.7390.55
'chrome driver 141.0.7390.54 (r1509326) (x64)

Sub chromedrivertest()

    Dim chrome As New Selenium.ChromeDriver, UrL As String
    
    
    UrL = "https://www.mobile01.com/topicdetail.php?f=511&t=4737630&p=156"
    chrome.Get UrL
    chrome.Wait 10000
 
 
 
    chrome.Quit
    Set chrome = Nothing

End Sub

ifye

ifye
個人積分：0分
文章編號：92242019

0分

1562樓

2025-10-06 13:24

S大你好
謝謝你的回覆

請問一下為什麼我加了下面的這一句(目的是要保持網頁是登入的狀態)
就沒辦法正確跑到想要的網址會停留在新分頁

chrome.SetProfile "%USERPROFILE%\AppData\Local\Google\Chrome\User Data", True

按中止以後就會跳出這個錯誤訊息
問了一下chatgpt是說"使用者資料目錄已被占用"
但是加了這一行也沒有用(重開excel前有叫出工作管理員確認詳細資料沒有chrome在執行)

' 步驟 1: 強制關閉所有 Chrome 進程，以釋放預設使用者資料目錄
Shell "taskkill /F /IM chrome.exe", vbHide ' /F 強制結束，/IM 指定 chrome.exe

謝謝

Sub test()

Dim chrome As New Selenium.ChromeDriver

' 步驟 1: 強制關閉所有 Chrome 進程，以釋放預設使用者資料目錄
Shell "taskkill /F /IM chrome.exe", vbHide ' /F 強制結束，/IM 指定 chrome.exe

chrome.SetProfile "%USERPROFILE%\AppData\Local\Google\Chrome\User Data", True
chrome.Get "https://reurl.cc/2LmpVn"
chrome.Wait 5000

Stop

chrome.Quit
Set chrome = Nothing

End Sub

snare

snare
個人積分：3143分
文章編號：92243005

3143分

樓主

2025-10-06 19:58

ifye wrote:
就沒辦法正確跑到想要的網址會停留在新分頁

這是chrome(edge)更新後，安全性增強後產生的問題，只有需要維持登入網頁才會
試了beta版的chromedriver，問題還在，不知什麼時候會修復。
花了一點時間，測試出暫時可正常執行的解決方式

步驟如下：
1、關閉chrome (含工作管理員，正在背景執行中的chrome)
2、到user data的路徑，C:\Users\使用者名稱\AppData\Local\Google\Chrome\User Data
3、把user data目錄，複制一份(改名)，這裡我暫時用 chromedriver 名稱

點我看大圖

4、以系統管理員身份執行 cmd (01發文自動變雙斜線)
start chrome.exe --user-data-dir="C:\\Users\\使用者名稱\\AppData\\Local\\Google\\Chrome\\chromedriver" --profile-directory="Default"

點我看大圖

5、接下來chrome會打開，把想要維持登入的網站，全部登入一遍
可以的話，本機不需要驗證(打勾)，讓user data更新資料，然後關掉chrome

6、程式碼修改如下，使用另一份user data來執行chrome

Sub test()

    Dim Chrome As New Selenium.ChromeDriver

    Chrome.AddArgument ("user-data-dir=C:\Users\使用者名稱\AppData\Local\Google\Chrome\chromedriver")
   
    Chrome.Get "https://reurl.cc/2LmpVn"
    Stop

    Chrome.Wait 3000
    Chrome.Quit
    Set Chrome = Nothing
    
End Sub

如果chrome出現驗證身份，第4步重新跑一次
點我看大圖

如果不想一直出驗證，也可把chrome捷徑(圖示)，
加入第4步，chrome.exe 後面的參數，暫時都用新的user data

點我看大圖

ifye

謝謝S大已正常使用感謝!!!

2025-10-09 4:54

f006116

f006116
個人積分：1分
文章編號：92460715

1分

1564樓

2025-11-24 21:14

S大您好!

近期11月份雅虎股市網頁不知是否有改版，我常用抓取股價的VBA突然無法下載了，還懇請解惑~
Thanks a lot !!

程式碼如下:

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(CallByName(DecodeJson, "price", VbGet), "raw", VbGet)
.Cells(k, 5) = CallByName(CallByName(DecodeJson, "bid", VbGet), "raw", VbGet)
.Cells(k, 6) = CallByName(CallByName(DecodeJson, "ask", VbGet), "raw", 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(CallByName(DecodeJson, "regularMarketPreviousClose", VbGet), "raw", VbGet)
.Cells(k, 10) = CallByName(CallByName(DecodeJson, "regularMarketOpen", VbGet), "raw", VbGet)
.Cells(k, 11) = CallByName(CallByName(DecodeJson, "regularMarketDayHigh", VbGet), "raw", VbGet)
.Cells(k, 12) = CallByName(CallByName(DecodeJson, "regularMarketDayLow", VbGet), "raw", 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

snare 樓主

請回1095樓，重新下載範例檔

2025-11-25 17:49

f006116

非常謝謝S大的幫忙! 我會再確認其差異性，再次感謝!!

2025-11-26 8:44

activer

activer
個人積分：0分
文章編號：92468896

0分

1565樓

2025-11-26 15:13

樓主您好,
本國上市證券國際證券辨識號碼一覽表(https://isin.twse.com.tw/isin/C_public.jsp?strMode=2),以範例程式無法下載,瀏覽器F12無法看到內容,能否指點一下修正方式?

snare

snare
個人積分：3143分
文章編號：92469485

3143分

樓主

2025-11-26 16:57

activer wrote:
本國上市證券國際證券辨識號碼一覽表(https://isin.twse.com.tw/isin/C_public.jsp?strMode=2),以範例程式無法下載,瀏覽器F12無法看到內容,能否指點一下修正方式?

f12 不是看不到，是因為這個網頁容量超大，單純文字表格就用10M
有些瀏覽器會直接顯示out of memory
有些要等超久才出來，快14萬行的原始碼

vba出錯是因為要轉編碼

點我看大圖

Sub get_twsw_isin()

    Dim URL As String, HTML As Object, GetXml As Object
    Set HTML = CreateObject("htmlfile")
    Set GetXml = CreateObject("msxml2.xmlhttp")
    
    URL = "https://isin.twse.com.tw/isin/C_public.jsp?strMode=2"

    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 = ConvertRaw(.ResponseBody)
      
      
        Set Table = HTML.all.tags("table")(1).Rows
        For i = 0 To Table.Length - 1
            For j = 0 To Table(i).Cells.Length - 1
                ActiveSheet.Cells(i + 1, j + 1) = Table(i).Cells(j).innertext
            Next j
        Next i
        
       
    End With

    Set HTML = Nothing
    Set GetXml = Nothing
    
End Sub

Function ConvertRaw(rawdata)

    Dim rawstr
    Set rawstr = CreateObject("adodb.stream")
    With rawstr
        .Type = 1
        .Mode = 3
        .Open
        .Write rawdata
        .Position = 0
        .Type = 2
        .Charset = "big5"
        ConvertRaw = .ReadText
        .Close
    End With
    
    Set rawstr = Nothing

End Function

activer

謝謝

2025-11-26 18:06

snare 樓主

通常用 debug.print .responsetext 檢查，vba會出錯無法顯示內容。另一種判斷方式就是把網頁另存新檔，用筆記本打開，如果中文全部不見，就是要轉編碼(可看上面原始碼那張圖)。

2025-11-26 18:49

activer

activer
個人積分：0分
文章編號：92470069

0分

1567樓

2025-11-26 18:53

snare wrote:
f12 不是看不到，...(恕刪)

樓主您好,請問由何處判斷要轉編碼?(前已回覆)

activer

activer
個人積分：0分
文章編號：92478494

0分

1568樓

2025-11-28 13:41

snare wrote:
f12 不是看不到，...(恕刪)

樓主您好,
依您的程式,已順利下載股票代號表;小弟欲將代號及名稱的分割,如下圖的1轉為2的格式時,但截取有關ETF的代號時,前面的0會消失(如0050會變為50),請問在截取代號時,要如何修正程式碼,才能在圖2的位置直接顯示為0050?(部分程式碼如下)

If cFicode = "ESVUFR" Or cFicode = "ESVTFR" Or cFicode = "ESVUFA" Or _
cFicode = "CEOGEU" Or cFicode = "CEOGDU" Or cFicode = "CEOGEU" Or cFicode = "CEOGMU" Or cFicode = "CEOGBU" Or _
cFicode = "CEOJEU" Or cFicode = "CEOIEU" Or cFicode = "CEOIBU" Or cFicode = "CEOIRU" Or cFicode = "CEOGCU" Or _
cFicode = "CEOJLU" Then ‘依cficode取得上市櫃股票資料(0050 CFICODE CEOGEU)

Cells(n, 1) = Split(Range("H" & i).Value, " ")(0) ‘顯示股票代號
Cells(n, 2) = Split(Range("H" & i).Value, " ")(1) '顯示名稱
Cells(n, 3) = Range("J" & i).Value '上市日
Cells(n, 4) = Range("K" & i).Value '市場別
Cells(n, 5) = Range("L" & i).Value '產業別
n = n + 1
End If

snare

snare
個人積分：3143分
文章編號：92479761

3143分

樓主

2025-11-28 17:31

activer wrote:
前面的0會消失

這是excel的問題，沒特別改成文字格式，0 就會消失
可先把 0050 加上單引號，改成 '0050 ，再放入儲存格

或是先把儲存格，改成文字格式

點我看大圖

activer

一行程式碼及符號"@",解決問題[謝謝]

2025-11-28 18:41

Dylan67

Dylan67
個人積分：7分
文章編號：92481133

7分

1570樓

2025-11-29 0:07

Snare大神：
我有付費這個網址https://www.104woo.com.tw/成為會員，請教我該怎麼用MicrosoftXmlHttp、Msxml2XmlHttp60、Msxml2ServerXmlHttp60、WinHttpRequest51物件來填入帳號密碼，或幾樓有類似範例，謝謝