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

機八陽 wrote:
可以把程式寫成只這樣只抓這部分~
而不是全部網頁的都抓下來嗎?

.........
.........
.........
Loop
        .document.all("FL_QRY").Click
      
        Application.Wait (Now + TimeValue("00:00:30"))
        
        Set Table = .Document.getelementsbytagname("table")(107).Rows

        For i = 0 To Table.Length - 1
            For j = 0 To Table(i).Cells.Length - 1
                ActiveSheet.Cells(i + 1, j + 1) = Table(i).Cells(j).innertext
            Next j
        Next i

If Err.Number <> 0 Th ..................
.........
.........
.........

機八陽 wrote:
後來我換了程式寫法~這一個是有抓到~

但一樣會顯示空白~
現在要進入頁面後按查詢才能~

'請參考828樓範例
'POST 改成 GET
'取消 do .... loop 迴圈，取消 if i=0 ........
'IIf(j = 1 …… 改成 IIf(j = 0 ……

    Url = "https://goodinfo.tw/StockInfo/StockList.asp?MARKET_CAT=自訂篩選&INDUSTRY_CAT=我的條件&FL_ITEM0=連續配發合計股利次數&FL_VAL_S0=7&FL_VAL_E0=&FL_ITEM1=累季–EPS年成長率(%)&FL_VAL_S1=0&FL_VAL_E1=&FL_ITEM2=&FL_VAL_S2=&FL_VAL_E2=&FL_ITEM3=&FL_VAL_S3=&FL_VAL_E3=&FL_ITEM4=&FL_VAL_S4=&FL_VAL_E4=&FL_ITEM5=&FL_VAL_S5=&FL_VAL_E5=&FL_ITEM6=&FL_VAL_S6=&FL_VAL_E6=&FL_ITEM7=&FL_VAL_S7=&FL_VAL_E7=&FL_ITEM8=&FL_VAL_S8=&FL_VAL_E8=&FL_ITEM9=&FL_VAL_S9=&FL_VAL_E9=&FL_ITEM10=&FL_VAL_S10=&FL_VAL_E10=&FL_ITEM11=&FL_VAL_S11=&FL_VAL_E11=&FL_RULE0=&FL_RULE1=&FL_RULE2=&FL_RULE3=&FL_RULE4=&FL_RULE5=&FL_RANK0=&FL_RANK1=&FL_RANK2=&FL_RANK3=&FL_RANK4=&FL_RANK5=&FL_FD0=&FL_FD1=&FL_FD2=&FL_FD3=&FL_FD4=&FL_FD5=&FL_SHEET=季累計獲利能力&FL_SHEET2=獲利能力&FL_MARKET=上市/上櫃&FL_QRY=查  詢"

    Url_a = Url

'程式碼放module(模組)裡，執行main()副程式
'因語法衝突，部份程式碼無法顯示，改用圖片代替文字，或請直接看附檔
'空白活頁薄需先手動建立18個工作表(名稱如下)
'volume_ALL、volume_TAI、volume_TWO、change-up_ALL、change-up_TAI、change-up_TWO'
'change-down_ALL、change-down_TAI、change-down_TWO
'day-range_ALL、day-range_TAI、day-range_TWO
'price_ALL、price_TAI、price_TWO、turnover_ALL、turnover_TAI、turnover_TWO
'(名稱可自行修改，但程式碼也需做適當的修改)


Sub main()

    Dim i As Integer, j As Integer, Url As String, sheet_name As String, urla(), urlb()
    
    
    '當日行情/成交量排行/即時行情排行
    '================================
      
    '成交量(volume)、漲幅(change-up)、跌幅(change-down)、價差(day-range)、成交價(price)、成交金額(turnover)
    urla = Array("volume", "change-up", "change-down", "day-range", "price", "turnover")
    
    '合併(ALL)、上市(TAI)、上櫃(TWO")
    urlb = Array("ALL", "TAI", "TWO")
    
    Application.ScreenUpdating = False
    
    For i = 0 To 5
        
        For j = 0 To 2
        
            Url = "https://tw.stock.yahoo.com/rank/" & urla(i) & "?exchange=" & urlb(j)
            sheet_name = urla(i) & "_" & urlb(j)
            
            If checksheet(sheet_name) = True Then
                Call GET_Yahoo_TW_Rank(Url, sheet_name)
            Else
                Debug.Print sheet_name & " ???"
            End If
            
            'Delaytick (0.5)
        Next j
    
    Next i


    Application.ScreenUpdating = True
    
    'Sheets("volume_ALL").Select
    
    MsgBox "ok", vbOKOnly, "Report"
    
End Sub



Sub GET_Yahoo_TW_Rank(Url As String, sheet_name As String)

    Dim Xmlhttp As Object, Jsondata As Object, DecodeJson, RankData, temp, i As Integer, ttt As Double
    
    Set Jsondata = CreateObject("HtmlFile")
    Set Xmlhttp = CreateObject("WinHttp.WinHttpRequest.5.1")



    
    ttt = Timer
    
    With Xmlhttp
    
       .Open "GET", Url, False
       .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
       .setRequestHeader "Cache-Control", "no-cache"
       .setRequestHeader "Pragma", "no-cache"
       .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
       .send
        
    End With
    
    
    temp = "{" & Split(Split(Xmlhttp.responsetext, "{""exchange"":""" & Right(sheet_name, 3) & """}}},")(1), ",""pagination"":{""resultsTotal")(0) & "}}}"

    Set DecodeJson = Jsondata.JsonParse(temp)
    Set RankData = CallByName(CallByName(CallByName(DecodeJson, "TableStore", VbGet), "main-0-StockRanking", VbGet), "list", VbGet)
      
      
    With Sheets(sheet_name)
    
        .Cells.Clear
        .Range("a3:k3") = Array("名次", "股名", "股號", "成交價", "漲跌", "漲跌幅(%)", "最高", "最低", "價差", "成交量(張)", "成交值(億)")

'點我看大圖(20210916修正2行程式碼，請自行修改附件)


'range("c1") 改成下面這行
        .Range("b2") = Replace(Split(CallByName(CallByName(CallByName(CallByName(DecodeJson, "TableStore", VbGet), "main-0-StockRanking", VbGet), "listMeta", VbGet), "rankTime", VbGet), "+")(0), "T", "  ")

      
        For i = 0 To 99
            Set temp = CallByName(RankData, i, VbGet)
            'debug '.Cells(I + 4, 1) = I + 1 & "(" & CallByName(temp, "rank", VbGet) & ")"
            .Cells(i + 4, 1) = i + 1
            .Cells(i + 4, 2) = temp.symbolName
            .Cells(i + 4, 3) = CallByName(temp, "symbol", VbGet)
            .Cells(i + 4, 4) = CallByName(temp, "price", VbGet)
            .Cells(i + 4, 5) = CallByName(temp, "change", VbGet)
            .Cells(i + 4, 6) = "'" & temp.changePercent
            
            If .Cells(i + 4, 5) <> 0 Then
                .Range("d" & i + 4 & ":f" & i + 4).Font.Color = IIf(.Cells(i + 4, 5) < 0, RGB(0, 171, 94), RGB(255, 51, 58))
                If .Cells(i + 4, 5) < 0 Then
                    .Cells(i + 4, 5) = Replace(.Cells(i + 4, 5), "-", "▼")
                    .Cells(i + 4, 6) = Replace(.Cells(i + 4, 6), "-", "▼")
                Else
                    .Cells(i + 4, 5) = "▲" & .Cells(i + 4, 5)
                    .Cells(i + 4, 6) = Replace(.Cells(i + 4, 6), "+", "▲")
                End If
            End If

            
            .Cells(i + 4, 7) = temp.dayHigh
            .Cells(i + 4, 8) = temp.dayLow
            .Cells(i + 4, 9) = temp.dayHighLowDiff
            .Cells(i + 4, 10) = temp.volK
            'debug '.Cells(i + 4, 11) = temp.turnoverK / 100000 & "(" & temp.turnoverK & ")"
            .Cells(i + 4, 11) = temp.turnoverK / 100000
        Next i

        .Range("K4:k103").NumberFormatLocal = "0.0000_ "
        .Range("j4:J103").NumberFormatLocal = "#,##0_ "
        .Range("d4:f103").Font.Bold = True
        .Cells.EntireColumn.AutoFit
        
    End With
    
    Debug.Print sheet_name & "=" & Timer - ttt & "s"
    
    Set Xmlhttp = Nothing
    Set Jsondata = Nothing
    Set DecodeJson = Nothing
    Set RankData = Nothing
    Set temp = Nothing
    
End Sub


Sub Delaytick(setdelay As Single)

    Dim StartTime As Double, NowTime As Double
    StartTime = Timer * 100
    setdelay = setdelay * 100
    Do
        NowTime = Timer * 100
        DoEvents
    Loop Until NowTime - StartTime > setdelay

End Sub




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

        .Range("b2") = Replace(Split(CallByName(CallByName(CallByName(CallByName(DecodeJson, "TableStore", VbGet), "main-0-StockRanking", VbGet), "listMeta", VbGet), "rankTime", VbGet), "+")(0), "T", "  ")

snare wrote:
(***此文只在mobile01...(恕刪)

bioleon69 wrote:
這兩天yahoo的是不是有改版動過?
無法更新惹

mickmini wrote:
網頁TABLE爬蟲解析工具(Excel VBA)
此檔案是 網頁 TABLE 格式 爬蟲範例.

oliwa wrote:
版大 , 因原使用網(恕刪)