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

bioleon69 wrote:
但上周好像改版了

bioleon69 wrote:
firdate可以抓出日期，但是是未分割的

snare wrote:
集保戶股權分散表，早(恕刪)

Dylan67 wrote:
我Google發現，可能是漢字ASCII轉Unicode的問題，
想請教怎麼把[𠄞]替換成[二]，
或是有更聰明的方法，在數據下載後能有個什麼模組，
將下載數據進行全部自動替換，

Sub test()
    
    Dim i As Integer, j As Integer, s As String
    
    Range("b:b").Interior.Pattern = xlNone
    
    For i = 3 To 6 'b3~b6
        s = Cells(i, 2)
        For j = 1 To Len(s)
            If Asc(Mid(s, j, 1)) = 63 And InStr(s, "?") = 0 Then
                Cells(i, 2).Interior.Color = vbGreen
                Exit For
            End If
        Next j
    Next i
    
End Sub

'程式碼放在模組裡，執行main()

Dim Request_denied As Boolean, prid As String
Sub main()

    Dim i As Integer, Detail, ttt As Double
    
    Detail = Array("1", "2", "3", "4", "6", _
                    "7", "37", "38", "9", "10", _
                    "11", "12", "13", "40", "41", _
                    "42", "43", "44", "45", "46", _
                    "47", "19", "20", "21", "22", _
                    "24", "39", "25", "26", "29", _
                    "48", "49", "30", _
                    "33", "51", "52")
'預設下載36個分類，31、32這2個未加入
'31=市認購，32=市認售
'市認購+市認售，約2萬5千筆資料，需要100~200秒，太花時間







'只下載36個分類，大約只要8秒
'如果需要31、32，請自行加入上面Detail 陣列中，也可自行刪減不要的項目






    Application.ScreenUpdating = False
    
    ttt = Timer
    Request_denied = False
    prid = ""
    
    For i = 0 To UBound(Detail)
        Call get_stock_classification(Detail(i))
        If Request_denied = True Then
            MsgBox "Request denied", vbOKOnly, "Error"
            Exit Sub
        End If
    Next i
        
    Application.ScreenUpdating = True
    
    Debug.Print "total time:" & Timer - ttt & "s"
    
End Sub



Sub get_stock_classification(sectorId)

    Dim Xmlhttp As Object, Jsondata As Object, Json, temp, URL As String, offset As Variant, sectorName As String, nextOffset As Variant, check As Boolean, Detail, resultsTotal As String, ttt As Double
    
    Set Jsondata = CreateObject("HtmlFile")
    Set Xmlhttp = CreateObject("msxml2.xmlhttp")





     On Error Resume Next
    
    ttt = Timer
    offset = 0
    check = True
    Detail = Array("symbolName", "symbol", "bid", "change", "changePercent", "regularMarketOpen", "regularMarketPreviousClose", "regularMarketDayHigh", "regularMarketDayLow", "volumeK", "regularMarketTime")
    
    If prid = "" Then
        
        With Xmlhttp
            .Open "GET", "https://tw.stock.yahoo.com/class-quote?sectorId=1&exchange=TAI", False
            .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
            prid = Split(Split(.responsetext, """prid"":""")(1), """,""region""")(0)
        End With
    
    End If
    
    
    Do
    
        URL = "https://tw.stock.yahoo.com/_td-stock/api/resource/StockServices.getClassQuotes;exchange=TAI;offset=" & offset & ";sectorId=" & sectorId & "?bkt=&device=desktop&ecma=modern&feature=ecmaModern,useNewQuoteTabColor&intl=tw&lang=zh-Hant-TW&partner=none&prid=" & prid & "®ion=TW&site=finance&tz=Asia/Taipei&ver=1.2.1506&returnMeta=true"
    
    
        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"
            .setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
            .send
            If Left(.responsetext, 14) = "Request denied" Then
                Request_denied = True
                Exit Sub
            End If
            Set Json = CallByName(Jsondata.JsonParse(.responsetext), "data", VbGet)
            nextOffset = CallByName(CallByName(Json, "pagination", VbGet), "nextOffset", VbGet)
            resultsTotal = CallByName(CallByName(Json, "pagination", VbGet), "resultsTotal", VbGet)
            Set Json = CallByName(Json, "list", VbGet)
            sectorName = CallByName(CallByName(Json, 0, VbGet), "sectorName", VbGet)
            
        End With
                
        If check = True Then
        
            If checksheet(sectorName) = False Then
                Sheets.Add(After:=Sheets(Sheets.Count)).Name = sectorName
            End If
                
            Sheets(sectorName).Cells.Clear
            Sheets(sectorName).Range("a1:k1") = Array("股票名稱", "代號", "股價", "漲跌", "漲跌幅(%)", "開盤", "昨收", "最高", "最低", "成交量 (張)", "時間")
            check = False
            
        End If
                
        With Sheets(sectorName)
            For i = 0 To CallByName(Json, "length", VbGet) - 1
                DoEvents
                Set temp = CallByName(Json, i, VbGet)
                For j = 1 To 11
                    If InStr("346789", j) = 0 Then
                        .Cells(i + 2 + offset, j) = CallByName(temp, Detail(j - 1), VbGet)
                    Else
                        .Cells(i + 2 + offset, j) = CallByName(temp, Detail(j - 1), VbGet).raw
                    End If
                Next j
                If .Cells(i + 2 + offset, j - 1) <> "" And .Cells(i + 2 + offset, j - 1) <> "-" Then
                    .Cells(i + 2 + offset, j - 1) = DateAdd("h", 8, Replace(Replace(.Cells(i + 2 + offset, j - 1), "T", " "), "Z", ""))
                End If
                
                Call add_color(i + offset, sectorName)
                
            Next i
        End With
         
        offset = nextOffset
        
    Loop Until IsNull(nextOffset)
         
    Sheets(sectorName).Columns.AutoFit
    Sheets(sectorName).Range("c:e").Font.Bold = True
    
    Debug.Print sectorId, sectorName, resultsTotal, Timer - ttt & "s"
        
    Set Xmlhttp = Nothing
    Set Jsondata = Nothing
    Set Json = Nothing
    Set temp = Nothing
    
    
End Sub

Function checksheet(sheet_name As String) As Boolean
    Dim check As Range
    On Error Resume Next
    Set check = Sheets(sheet_name).Range("a1")
    If Err.Number <> 0 Then checksheet = False Else checksheet = True
    On Error GoTo 0
End Function


Sub add_color(r As Integer, sheet_name As String)
    
    With Sheets(sheet_name)
        
        If .Cells(r + 2, 4) <> "-" Then
            Select Case .Cells(r + 2, 4)
                Case Is > 0
                    .Range("c2:e2").offset(r, 0).Font.Color = vbRed
                    .Range("d2").offset(r, 0) = "▲" & .Range("d2").offset(r, 0)
                    .Range("e2").offset(r, 0) = "▲" & .Range("e2").offset(r, 0) * 100 & "%"
                Case Is < 0
                    .Range("c2:e2").offset(r, 0).Font.Color = -11489280
                    .Range("d2").offset(r, 0) = Replace(.Range("d2").offset(r, 0), "-", "▼")
                    .Range("e2").offset(r, 0) = Replace(.Range("e2").offset(r, 0) * 100 & "%", "-", "▼")
            End Select
        End If
        
    End With
    
End Sub

rainbowsperm wrote:
研究了好久還是想不出辦法
不知有無辦法可在資料匯入前 先將多的空白行處理掉?

Sub getstock()
    
    Dim URL As String, HTML As Object, GetXml As Object, i As Integer, temp
    Set HTML = CreateObject("htmlfile")
    Set GetXml = CreateObject("msxml2.xmlhttp")
    URL = "https://5850web.moneydj.com/z/zc/zcr/zcra/zcra_3231.djhtm"
    
    Sheets("工作表1").Cells.Clear
    
    With GetXml
        .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"
        .setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
        .send

        HTML.body.innerhtml = .responsetext
        Set Table = HTML.all.tags("table")(1).Rows
        
        temp = Split(Replace(Replace(Table(0).Cells(0).innertext, " / ", "/"), """", ""), vbNewLine)
        'temp = Split(Replace(Table(0).Cells(0).innertext, " / ", "/"), vbNewLine)

        For i = 0 To UBound(temp)
            Sheets("工作表1").Cells(i + 1, 1) = temp(i)
        Next i
        
        Sheets("工作表1").Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, Space:=True, Other:=False, TrailingMinusNumbers:=True
        
        Sheets("工作表1").Columns.AutoFit
        
    End With
    
    Set HTML = Nothing
    Set GetXml = Nothing
    
End Sub