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

'====程式碼，請放在“模組”裡============
Sub getpost()

    Cells.Clear
     
    Dim HTMLsourcecode As Object, Url As String, Url_a As String, TempArray(), Table, Title, Getxml As Object, ttt As Double
    Set HTMLsourcecode = CreateObject("htmlfile")
    Set Getxml = CreateObject("msxml2.xmlhttp")
    
    stock = InputBox("股票代號", , 2412)
    startday = Format(InputBox("開始日期(8碼數字)", , "20170101"), "####/##/##")
    endday = Format(InputBox("結束日期(8碼數字)", , Format(Date, "yyyymmdd")), "####/##/##")
     
     Url = "https://www.cnyes.com/archive/twstock/ps_historyprice/" & stock & ".htm"
   
    Url_a = "pageTypeHidden=1&code=" & stock & _
    "&ctl00$ContentPlaceHolder1$startText=" & startday & _
    "&ctl00$ContentPlaceHolder1$endText=" & endday & _
    "&ctl00$ContentPlaceHolder1$submitBut=查詢"
   
    ttt = Timer
    Application.ScreenUpdating = False
       
    With Getxml
        .Open "POST", Url, False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .setRequestHeader "Referer", Url
        .setRequestHeader "Cache-Control", "no-cache"
        .setRequestHeader "Pragma", "no-cache"
        .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
        .send (Url_a)
        
        HTMLsourcecode.body.innerhtml = .Responsetext
        Title = stock & HTMLsourcecode.getelementbyid("ctl00_ContentPlaceHolder1_titleLab").innertext
        Set Table = HTMLsourcecode.all.tags("table")(0).Rows
        ReDim TempArray(Table.Length - 1, Table(2).Cells.Length - 1)
      
       
        For i = 0 To Table.Length - 1
            For j = 0 To Table(i).Cells.Length - 1
                TempArray(i, j) = Table(i).Cells(j).innertext
                If (i > 0 And j = 5) Then
                    With Sheets("sheet1")
                        If TempArray(i, j) > 0 Then .Range(.Cells(i + 1, 5), .Cells(i + 1, 7)).Font.Color = -16776961
                        If TempArray(i, j) < 0 Then .Range(.Cells(i + 1, 5), .Cells(i + 1, 7)).Font.Color = -11489280
                    End With
                End If
            Next j
        Next i
        
        With Sheets("sheet1")
            .Range(.Cells(1, 1), .Cells(Table.Length, Table(2).Cells.Length)) = TempArray()
        End With
    End With
   
    Application.ScreenUpdating = True
    MsgBox Title & vbNewLine & "開始日期" & startday & vbNewLine & "結束日期" & endday & vbNewLine & "資料筆數" & Table.Length - 1 & vbNewLine & "使用時間" & Round(Timer - ttt, 2) & "秒", vbOKOnly, "下載完成"
    
    Set HTMLsourcecode = Nothing
    Set Table = Nothing
    Set Getxml = Nothing
    Erase TempArray()
    
End Sub

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

Sub Get_cnyes_Jsondata()

    Dim Xmlhttp As Object, Jsondata As Object, Url As String, Url_a As String, stock As String, startday As String, endday As String, ttt As Double, DecodeJson, i As Integer
    Set Jsondata = CreateObject("HtmlFile")
    Set Xmlhttp = CreateObject("msxml2.xmlhttp")
    

 

    Sheets("工作表1").Cells.Clear
    Sheets("工作表1").Range("a1:h1") = Array("日期", "開盤", "最高", "最低", "收盤", "漲跌", "漲跌(%)", "成交張數")
    
    stock = InputBox("股票代號", , "2330")
    
    startday = Format(InputBox("開始日期(多減一天)(8碼數字)", , Format(Date - 91, "yyyymmdd")), "####/##/##")
    endday = Format(InputBox("結束日期(多加一天)(8碼數字)", , Format(Date + 1, "yyyymmdd")), "####/##/##")
    
    
    If startday > endday Or stock = "" Or startday = "" Or endday = "" Then
        MsgBox "資料輸入錯誤", vbOKOnly, "請重新輸入"
        Exit Sub
    End If
    
    ttt = Timer
    
    Url = "https://ws.api.cnyes.com/ws/api/v1/charting/history?resolution=D&symbol=TWS:" & stock & ":STOCK&from=" & DataToUnixTime(endday) & "&to=" & DataToUnixTime(startday) & ""e=1"
    Url_a = "https://invest.cnyes.com/twstock/TWS/" & stock & "/history#fixed"
    
    With Xmlhttp
       .Open "GET", Url, False
       .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
       .setRequestHeader "Referer", Url_a
       .send
        Set DecodeJson = CallByName(Jsondata.JsonParse(.responsetext), "data", VbGet)
    End With
    
    With Sheets("工作表1")
        Application.ScreenUpdating = False
                
        For i = 0 To CallByName(CallByName(DecodeJson, "t", VbGet), "length", VbGet) - 1
            
            .Cells(i + 2, 1) = Format(CallByName(CallByName(DecodeJson, "t", VbGet), i, VbGet) / 86400 + #1/1/1970 8:00:00 AM#, "yyyy/mm/dd")
            .Cells(i + 2, 2) = CallByName(CallByName(DecodeJson, "o", VbGet), i, VbGet)
            .Cells(i + 2, 3) = CallByName(CallByName(DecodeJson, "h", VbGet), i, VbGet)
            .Cells(i + 2, 4) = CallByName(CallByName(DecodeJson, "l", VbGet), i, VbGet)
            .Cells(i + 2, 5) = CallByName(CallByName(DecodeJson, "c", VbGet), i, VbGet)
            If i > 0 Then
                .Cells(i + 2 - 1, 6) = .Cells(i + 2 - 1, 5) - .Cells(i + 2, 5)
                .Cells(i + 2 - 1, 7) = Round((.Cells(i + 2 - 1, 6) / .Cells(i + 2, 5)) * 100, 2) & "%"
                
                If .Cells(i + 2 - 1, 6) > 0 Then
                   .Cells(i + 2 - 1, 5).Font.Color = vbRed
                   .Cells(i + 2 - 1, 6).Font.Color = vbRed
                   .Cells(i + 2 - 1, 7).Font.Color = vbRed
                End If
                If .Cells(i + 2 - 1, 6) < 0 Then
                   .Cells(i + 2 - 1, 5).Font.Color = -11489280
                   .Cells(i + 2 - 1, 6).Font.Color = -11489280
                   .Cells(i + 2 - 1, 7).Font.Color = -11489280
                End If
            End If
            .Cells(i + 2, 8) = CallByName(CallByName(DecodeJson, "v", VbGet), i, VbGet)
            
        Next i
        
        'debug
        .Cells(1, 10) = stock
        .Cells(1, 11) = Format(.Cells(i, 1), "yyyy/mm/dd")
        .Cells(1, 12) = Format(.Cells(2, 1), "yyyy/mm/dd")
        
        .Rows(i + 1).Clear
        .Cells.EntireColumn.AutoFit
        .Cells(1, 1).Select
        
        Application.ScreenUpdating = True
        
    End With
    
    Debug.Print Timer - ttt
    
    Set Xmlhttp = Nothing
    Set DecodeJson = Nothing
    Set Jsondata = Nothing
    
End Sub

Function DataToUnixTime(dstring) As Long

DataToUnixTime = (DateValue(dstring) - #1/1/1970 8:00:00 AM#) * 86400

End Function

        't 日期
        'o 高盤
        'h 最高
        'l 最低
        'c 收盤
        'v 成交張數

snare wrote:
看了麻辣那邊一大堆的...(恕刪)

keeptry wrote:
各位大大好，很幸運...(恕刪)

keeptry wrote:
但不管是71樓或75樓的程式碼，跑到 Set Table 的時候，就會出現錯誤...(恕刪)

snare wrote:
'===可惜這些代碼、網址，只適用這個範例網站===============
'===只要換網站就要重新看網頁原始碼、追蹤網址、找出正確代碼==
...(恕刪)

snare wrote:
因為post 方式，在不同的網站，程式碼也會不同...(恕刪)

bioleon69 wrote:
還弄了一個MSGBOX...(恕刪)