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

oliwa wrote:
如下是騰訊的收盤價 , 想要把它全部轉出來使用 , 謝謝 !!
https://stockapp.finance.qq.com/mstats/#mod=list&id=ssa&module=SS&type=ranka

Sub qq()

    Dim Xmlhttp As Object, Url As String, StockName As String, stock, temp, i As Integer, r As Long
    Set Xmlhttp = CreateObject("msxml2.xmlhttp")
        
    Cells.Clear
    Application.ScreenUpdating = False
    Range("a1:m1") = Array("代碼", "名稱", "最新價", "漲跌幅", "漲跌額", "買入", "賣出", "成交量", "成交額", "今開", "昨收", "最高", "最低")
    
    
    'StockName = "sh688700" 'test
    'StockName = "sh688700,sh688609" 'test
    StockName = "sh688700,sh603529,sh605259,sz300134,sz300076,sz300649,sz300235,sh688579"
    '股票代碼用,(逗點)區隔，不確定是否能一次查詢超過80筆，請自行測試
    '如果代碼數量太多，建議改用迴圈處理

    Url = "https://qt.gtimg.cn/q=" & StockName
    
    With Xmlhttp
        .Open "GET", Url, False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .setRequestHeader "Cache-Control", "no-cache"
        .setRequestHeader "Pragma", "no-cache"
        .setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
        .send
        
        stock = Split(.Responsetext, ";")
        
        r = 1
        For i = 0 To UBound(stock) - 1
            temp = Split(stock(i), "~")
            r = r + 1
            Cells(r, 1) = temp(2)
            Cells(r, 2) = temp(1)
            Cells(r, 3) = temp(3)
            Cells(r, 4) = temp(32) & "%"
            Cells(r, 5) = temp(31)
            Cells(r, 6) = temp(19)
            Cells(r, 7) = temp(3)
            Cells(r, 8) = temp(36)
            Cells(r, 9) = temp(37)
            Cells(r, 10) = temp(5)
            Cells(r, 11) = temp(4)
            Cells(r, 12) = temp(33)
            Cells(r, 13) = temp(34)
        Next i
 
    End With
    
    Cells.EntireColumn.AutoFit
    Application.ScreenUpdating = True
    
    Set Xmlhttp = Nothing
    
End Sub

Dylan67 wrote:
我將下載的數據分別寫入數個資料庫供取用，現在遇到難題，爬了很多文章都沒能得到解決，我希望將字串轉為代碼運行(如附件--建立資料庫連結)

Sub test()
    Open "c:\test.bat" For Output As #1
    Print #1, "echo off"
    Print #1, "echo 一二三abc"
    Print #1, "echo 四五六def"
    Print #1, "pause"
    Close #1
    Shell "c:\test.bat", vbNormalFocus
End Sub

Sub test1()

    Dim DB1 As Object, RS1 As Object, DB2 As Object, RS2 As Object
    Dim TargetA As String, TargetB As String, Sql1 As String, Sql2 As String

    Set DB1 = CreateObject("ADODB.Connection")
    Set DB2 = CreateObject("ADODB.Connection")
    Set RS1 = CreateObject("ADODB.Recordset")
    Set RS2 = CreateObject("ADODB.Recordset")

    TargetA = ThisWorkbook.Path & "\aaa.accdb"
    TargetB = ThisWorkbook.Path & "\bbb.accdb"
    
    Sql1 = "sql的程式碼"
    Sql2 = "sql的程式碼"
    
    DB1.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & TargetA & ";"
    RS1.Open Sql1, DB1, 3, 3
    DB2.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & TargetA & ";"
    RS2.Open Sql2, DB2, 3, 3
    
    Sheets("工作表1").Cells.Clear
    Sheets("工作表1").Cells(1, 1).CopyFromRecordset RS1
    Sheets("工作表2").Cells.Clear
    Sheets("工作表2").Cells(1, 1).CopyFromRecordset RS2

    RS1.Close
    RS2.Close
    DB1.Close
    DB2.Close

    Set RS1 = Nothing
    Set RS2 = Nothing
    Set DB1 = Nothing
    Set DB2 = Nothing


End Sub

Sub test2()

    Call test3(ThisWorkbook.Path & "\aaa.accdb", "sql的程式碼", "工作表1")
    Call test3(ThisWorkbook.Path & "\bbb.accdb", "sql的指令碼", "工作表2")
    
End Sub


Sub test3(TargetDb As String, SqlStr As String, Sheet_Name As String)

    Dim DB As Object, RS As Object
    Set DB = CreateObject("ADODB.Connection")
    Set RS = CreateObject("ADODB.Recordset")
 
    DB.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & TargetDb & ";"
    RS.Open SqlStr, DB, 3, 3
    
    Sheets(Sheet_Name).Cells.Clear
    Sheets(Sheet_Name).Cells(1, 1).CopyFromRecordset RS
    
    RS.Close
    DB.Close

    Set RS = Nothing
    Set DB = Nothing


End Sub

oliwa wrote:
不過目前抓資料較費時 , 100筆至少要 10 min ........

oliwa wrote:
利用廻圈設定資料範圍時 , 因為代碼中有跳號 , 無法直接設定一,二個廻圈下載 , 再加上 500 筆限制 ,
這個抓資料的廻圈變多且不好維護

oliwa wrote:
http://www.tfzq.com/www.sse.com.cn/market/price/report/

oliwa wrote:
http://www.szse.cn/market/trend/index.html

#If VBA7 Then
    Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
    Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, _
    ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#Else
    Private Declare Function URLDownloadToFile Lib "urlmon" _
    Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, _
    ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#End If



Sub TEST()
    '日期暫訂2021-06-18
    Dim Url As String, Target As String
    
    Target = "d:\excel\" '暫存目錄
    If Dir(Target, vbDirectory) = "" Then MkDir Target
    '注意，暫存目錄下的檔案，會在無任何提示下刪除
    If Dir(Target & "*.*") <> "" Then Kill Target & "*.*"
    Url = "http://www.szse.cn/api/report/ShowReport?SHOWTYPE=xlsx&CATALOGID=1815_stock&TABKEY=tab1&txtBeginDate=2021-06-18&txtEndDate=2021-06-18&radioClass=00,20,30&txtSite=all"
    
    URLDownloadToFile 0, Url, Target & "股票行情.xlsx", 0, 0
 

End Sub

oliwa wrote:
另外 http://www.tfzq.com/www.sse.com.cn/market/price/report/ , 原本回覆是單頁下載要 79 頁 ,
這部分程式可以分享嘛 ?

' 0~500 筆，簡易範例，500~最後一筆，請自行改寫

Sub tfzq()

    Dim Xmlhttp As Object, JsonData As Object, temp, Url As String, i As Integer, r As Long
    
    Set Xmlhttp = CreateObject("msxml2.xmlhttp")
    Set JsonData = CreateObject("HtmlFile")
'    JsonData.write  …… 這行因語法關係無法正常顯示，請到1024樓copy

        
    Cells.Clear
    Application.ScreenUpdating = False
    Range("a1:m1") = Array("序號", "證券代碼", "證券簡稱", "類型", "最新", "漲跌幅", "漲跌", "成交量(手)", "成交額(萬元)", "前收", "開盤", "最高", "最低")
    

    Url = "http://yunhq.sse.com.cn:32041//v1/sh1/list/exchange/equity?select=code,name,open,high,low,last,prev_close,chg_rate,volume,amount,tradephase,change,amp_rate,cpxxsubtype,cpxxprodusta&order=&begin=0&end=500&_="
    
    With Xmlhttp
    
        .Open "GET", Url & ((Now() - #1/1/1970 8:00:00 AM#) * 86400), False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .setRequestHeader "Cache-Control", "no-cache"
        .setRequestHeader "Pragma", "no-cache"
        .setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
        .send
        
        
        Set decodejson = JsonData.JsonParse(.responsetext)
        
        'debug
        MsgBox "資料合計：" & CallByName(decodejson, "total", VbGet) & "筆" & vbNewLine & _
               "日    期：" & CallByName(decodejson, "date", VbGet) & vbNewLine & _
               "時    間：" & CallByName(decodejson, "time", VbGet), vbOKOnly, "debug"
        
            
        For i = 0 To CallByName(CallByName(decodejson, "list", VbGet), "length", VbGet) - 1
            temp = Split(CallByName(CallByName(decodejson, "list", VbGet), i, VbGet), ",")
            
            Cells(i + 2, 1) = i + 1
            Cells(i + 2, 2) = temp(0)
            Cells(i + 2, 3) = temp(1)
            'cells(i+2,4)="i don't know"
            Cells(i + 2, 5) = temp(5)
            Cells(i + 2, 6) = temp(7) & "%"
            Cells(i + 2, 7) = temp(11)
            Cells(i + 2, 8) = temp(8)
            Cells(i + 2, 9) = temp(9)
            Cells(i + 2, 10) = temp(6)
            Cells(i + 2, 11) = temp(2)
            Cells(i + 2, 12) = temp(3)
            Cells(i + 2, 13) = temp(4)
        
        Next i
        
 
    End With
    
    Cells.EntireColumn.AutoFit
    Application.ScreenUpdating = True
    
    Set Xmlhttp = Nothing
    Set JsonData = Nothing
    
End Sub