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

snare wrote:
(20190930 20...(恕刪)

victor0726 wrote:
前陣子上櫃盤後的csv檔無法自動下載了...(恕刪)

victor0726 wrote:
不知道差別在哪裡。 非常感謝您。...(恕刪)

alantsai5840 wrote:
306樓的 Wantgoo.xlsm 檔 最近執行 顯現"安全通道支援錯誤" 不知網站是改變問題 ? (恕刪)

peter624 wrote:
(https://www.tpex.org.tw/web/stock/statistics/monthly/monthly_rpt_mkt_info_dl.php?DOC_ID=2118)，另外檢查網頁原始碼，也沒有發現對應的table在哪裡。
(恕刪)

peter624 wrote:
請問我要用VBA下載此網站(https://www.tpex.org.tw/web/stock/statistics/monthly/monthly_rpt_mkt_info_05.php?l=zh-tw)的EXCEL檔，但是發現他的每月份下載網址比如108/11參數DOC_ID=2118，DOC_ID每月的值沒有一定的規則性，我要如何去取得DOC_ID然後下載(恕刪)

'取得下載網址範例
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

    Set Jsondata = CreateObject("HtmlFile")
    Jsondata.write ”＜script＞document.JsonParse＝function （s） ｛return eval（’（’ ＋ s ＋ ’）’）；｝＜／script＞”
'jsondata.write 這行符號是全形字，請自行改成半形，或回頭找其它檔案中的程式碼
    
    Sheets("工作表1").Cells.Clear
    
    sd = "99/02"
    ed = "108/12"
    
    Url = "https://www.tpex.org.tw/web/stock/statistics/monthly/monthly_rpt_mkt_info_result.php?l=zh-tw&t=5&sd=" & sd & "&ed=" & ed & "&_="
    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
        .send
        
        Set DecodeJson = Jsondata.JsonParse(.responsetext)
        Set temp = CallByName(DecodeJson, "aaData", VbGet)
        
        For i = 0 To CallByName(temp, "length", VbGet) - 1
            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
        
    Set Xmlhttp = Nothing
    Set DecodeJson = Nothing
    Set Jsondata = Nothing
    Set temp = Nothing
  
End Sub

Function UNIXTime()

    UNIXTime = Round(((Date - #1/1/1970#) * 86400 + Timer) * 1000, 0)

End Function

'下載檔案範例
'部份程式碼，請參考269樓、271樓，自行加入
Sub download()

    Dim Xmlhttp As Object
    Dim Url As String, Url_a As String, FileName As String
    
    Url = "https://www.tpex.org.tw/web/stock/statistics/monthly/monthly_rpt_mkt_info_dl.php?DOC_ID=2118"
    Url_a = "https://www.tpex.org.tw/web/stock/statistics/monthly/monthly_rpt_mkt_info_05.php?l=zh-tw"

    Set Xmlhttp = CreateObject("Msxml2.XMLHTTP")
    
    With Xmlhttp
        .Open "GET", Url, False
        .setRequestHeader "Referer", Url_a
        .send
        
        '取檔名程式碼
    End With
        
        '存檔程式碼

        '開檔程式碼，請自行錄巨集使用workbooks.open，或建立CreateObject("Excel.Application")
    
    Set Xmlhttp = Nothing
 
End Sub

'部份程式碼，請參考61樓，自行加入
'64位元excel ，Private Declare  需改成 Private Declare PtrSafe
Sub test()
    URLDownloadToFile 0, "網址", "完整路徑+自訂檔名(自訂副檔名)", 0, 0
End Sub