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

alantsai5840 wrote:
RUN TEST3 有程式有階段錯誤''91''的問題 ...(恕刪)

cji3cj6xu6 wrote:
在excel 2007可以執行，但2010卻會出現錯誤，...(恕刪)

'==============================================================
'這個範例，跟269樓一樣，提供2種不同的下載方式
'==============================================================
Sub Get_rate_hd()

    Dim Xmlhttp As Object, FileName As String, Url As String, ttt As Double
    Set Xmlhttp = CreateObject("Msxml2.XMLHTTP")
    ttt = Timer
    
    Url = "https://rate.bot.com.tw/xrt/flcsv/0/day"
    On Error Resume Next
    
    With Xmlhttp
       
       .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
        
        FileName = Replace(Replace(.getresponseheader("Content-Disposition"), "attachment; filename=", ""), """", "")
        
    End With
    
    With CreateObject("ADODB.Stream")
        .Type = 1
        .Open
        .write Xmlhttp.ResponseBody
        .savetofile ThisWorkbook.Path & "\" & FileName, 2
'預設存檔路徑，和工作表相同目錄
'注意：相同檔名的檔案，會在無任何提示下覆蓋

        .Close
        
        Workbooks.OpenText FileName:=ThisWorkbook.Path & "\" & FileName, Origin:= _
        65001, StartRow:=1, DataType:=xlDelimited, Comma:=True, TrailingMinusNumbers:=True

        Cells.Columns.AutoFit
        MsgBox FileName & vbNewLine & "資料筆數" & ActiveSheet.Range("a1").CurrentRegion.Rows.Count - 1 & "筆" & _
        vbNewLine & "下載使用時間" & Timer - ttt & "秒" & _
        vbNewLine & "牌價最新掛牌時間：" & Format(Mid(FileName, 14, 12), "####-##-## ##:##"), vbOKOnly
    End With
    
    Windows(FileName).Activate
    ActiveWindow.WindowState = xlMaximized
    
    Set Xmlhttp = Nothing
    
End Sub

Sub Get_rate_memory()

    Dim Xmlhttp As Object, Clipboard As Object, Url As String, Update As String, ttt As Double
    Set Clipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    Set Xmlhttp = CreateObject("Msxml2.XMLHTTP")
    
    ttt = Timer
    
    Url = "https://rate.bot.com.tw/xrt/flcsv/0/day"
    
    On Error Resume Next
    With Xmlhttp
        .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
        Update = Left(Split(Xmlhttp.getresponseheader("Content-Disposition"), "@")(1), 12)
    End With
    
    Clipboard.SetText Xmlhttp.responsetext
    Clipboard.PutInClipboard

   With Sheets("工作表1")
        .Select
        .Rows("4:" & .Rows.Count).ClearContents
        .Cells(4, 1).Select
        .PasteSpecial NoHTMLFormatting:=True
        Selection.TextToColumns DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, Comma:=True
        .Columns.AutoFit
        .Cells(1, 1).Select
        MsgBox "不存檔直接開啟" & vbNewLine & "牌價最新掛牌時間" & Format(Update, "####/##/## ##:##") & vbNewLine _
        & "資料筆數" & .Range("a4").CurrentRegion.Rows.Count - 1 & "筆" & vbNewLine & "下載使用時間" & Timer - ttt & "秒", vbOKOnly, "下載完成"
    End With
    
    Set Xmlhttp = Nothing
    Set Clipboard = Nothing
  
End Sub

'===============================================================