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

alfidpan wrote:
感謝回應，那不用VBA，還有機會匯入嗎？

Dylan67 wrote:
第1個是台灣集保結算所https://www.tdcc.com.tw/portal/zh/stats/openData，我發現右鍵就可以很容易取得路徑https://opendata.tdcc.com.tw/getOD.ashx?id=1-5，但這是最新的數據，我想請問是不是有機會加入某個時間參數，可以取得歷史的數據

Dylan67 wrote:
第二個是公開資訊觀測站https://mopsov.twse.com.tw/mops/web/stapap1_all，這個有列出公司名稱，但想看詳細資料，就必須一個一個點擊，有沒有什麼方法可以把所有公司的詳細資料全部抓下來，謝謝

Sub Get_twse_stapap1_all_Link()

    Dim HTML As Object, Getxml As Object, table As Object, i As Integer, j As Integer, UrL As String
    Dim Ie_Open As Boolean, PostData As String, YM As String, skind As String
    
    'Ie_Open = True '使用超連結，點擊插入註解，打開瀏覽器
    Ie_Open = False '使用文字格式網址，點擊插入註解，但不打開瀏覽器
    
    Set HTML = CreateObject("htmlfile")
    Set Getxml = CreateObject("msxml2.xmlhttp")
    
   '01 水泥工業 02 食品工業 03 塑膠工業 04 紡織纖維 05 電機機械 06 電器電纜 07 化學生技醫療 08 玻璃陶瓷 09 造紙工業 10 鋼鐵工業
   '11 橡膠工業 12 汽車工業 13 電子工業 14 建材營造 15 航運業 16 觀光餐旅 17 金融保險業 18 貿易百貨 19 綜合企業 20 其他
   '21 化學工業 22 生技醫療業 23 油電燃氣業 24 半導體業 25 電腦及週邊設備業 26 光電業 27 通信網路業 28 電子零組件業 29 電子通路業 30 資訊服務業
   '31 其他電子業 35 綠能環保 36 數位雲端 37 運動休閒 38 居家生活 91 存託憑證
    
    
    YM = "11503"
    skind = "14"
    UrL = "https://mopsov.twse.com.tw/mops/web/ajax_stapap1_all"
           
    PostData = "encodeURIComponent=1&sTYPEK=sii&TYPEK=sii&firstin=true&step=1&kind=&id=&skind=" & skind & "&YM=" & YM
    
    
    Sheets("工作表1").Cells.Clear
    Sheets("工作表1").Columns("A:A").NumberFormatLocal = "@"
    Application.ScreenUpdating = False
    
    
    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 (PostData)
        HTML.body.innerhtml = .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 + 1, j + 1) = Trim(table(i).Cells(j).innertext)
            
            If i > 0 And j = 2 Then
                          
                PostData = "https://mopsov.twse.com.tw/mops/web/ajax_stapap1?encodeURIComponent=1&firstin=true&colorchg=&year=" & Left(YM, 3) & "&month=" & Right(YM, 2) & "&co_id=" & Sheets("工作表1").Cells(i + 1, 1) & "&TYPEK=sii&step=0"
                
                If Ie_Open = True Then
                    Sheets("工作表1").Hyperlinks.Add Sheets("工作表1").Cells(i + 1, j + 1), Address:=PostData, TextToDisplay:="詳細資料"
                Else
                    Sheets("工作表1").Cells(i + 1, 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
    
End Sub

'單筆下載範例，多筆請自行取用工作表1的C欄網址，用迴圈改寫



Sub Get_twse_stapap1_Link_Data()

    Dim HTML As Object, Getxml As Object, Clipboard As Object, table, UrL As String, ttt As Double
    
    Set Clipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    Set HTML = CreateObject("htmlfile")
    Set Getxml = CreateObject("msxml2.xmlhttp")
    
    ttt = Timer
    
    
    If Sheets("工作表1").Range("c2").Hyperlinks.Count > 0 Then
        UrL = Sheets("工作表1").Range("c2").Hyperlinks(1).Address
    Else
        UrL = Sheets("工作表1").Range("c2").Value
    End If
    
    
    Sheets("工作表2").Cells.Clear
    
    
    With Getxml
        
        .Open "POST", UrL, False
        .setRequestHeader "Referer", "https://mops.twse.com.tw/mops/web/t05st01"
        .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
        HTML.body.innerhtml = .responsetext
        
    End With
    
    
    If InStr(HTML.body.innertext, "查詢過於頻繁") > 0 Then
        Debug.Print HTML.body.innertext
    Else
        Clipboard.SetText HTML.body.innerhtml
        Clipboard.PutInClipboard
            
        Sheets("工作表2").Select
        Sheets("工作表2").Cells(1, 1).Select
        Sheets("工作表2").PasteSpecial NoHTMLFormatting:=True
    End If
    
    Sheets("工作表2").Columns.AutoFit
    Sheets("工作表2").Columns("A:A").ColumnWidth = 33
    
    Set HTML = Nothing
    Set Getxml = Nothing
    Set table = Nothing
    Set Clipboard = Nothing
    
    Debug.Print Timer - ttt & "s"
    
End Sub

alfidpan wrote:
以上的網址寫VBA想要匯入JSON，會出現status 403，是否是網站有反爬蟲，還是程式碼寫錯了呢？

snare wrote:
寫錯吧? 不然就是你...(恕刪)

Dylan67 wrote:
我使用 URLDownloadToFile 方法可以順利下載

URLDownloadToFile 0, Url, Target & "DownLoad.csv", 0, 0

可是使用 WinHttpRequest51 卻不行，想請教為什麼？

Dylan67 wrote:
應該是Token抓取錯誤(有抓到但是是錯的Token)