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

peter624

5分

1011樓

peter624

個人積分：5分

文章編號：81757073

snare大大你好

可以請教一下，今天早上在執行VBA讀取CSV檔時，會發生無法開啟的情形(程式碼

紅色的部分)，到昨天為止都可以執行，想請問是office版本的關係嗎，執行的程式碼部分如下，希望大大幫忙一下，感謝。

Sub 下載當月最高最低股價2_CSV()

Dim F As Boolean
Dim month1, year1
Dim rs As Object
Dim stockid As String

year1 = "2021"

Set rs = CreateObject("ADODB.Recordset")

strcon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & "E:\123\每年營收\" & year1 & "\;" _
& "Extended Properties=""text;HDR=Yes;FMT=Delimited"";"

s = "E:\123\每年營收\2021\202101.csv"
F = CreateObject("Scripting.FileSystemObject").FileExists(s)
If F = True Then

strSQL = "SELECT * FROM 202101.csv WHERE 公司 LIKE '%" & "6176" & "%'"

End If

rs.Open strSQL, strcon, 3, 3

Sheets("歷年營收").row(1.1) = rs("上月比較")

Set rs = Nothing '釋放物件變數
Set WebSht1 = Nothing
Set WebSht2 = Nothing

snare

2602分

樓主

snare

個人積分：2602分

文章編號：81757691

peter624 wrote:
紅色的部分)，到昨天為止都可以執行，想請問是office版本的關係嗎

沒檔案無法測試

您可以試著把12改成14、15、16試看看
Microsoft.ACE.OLEDB.14.0
Microsoft.ACE.OLEDB.15.0
Microsoft.ACE.OLEDB.16.0

或找出昨天、今天，您電腦異動了什麼程式，做了什麼修改…
最糟的情況是Microsoft Access Database Engine 可轉散發套件壞了

但我剛剛找了2台電腦測試
一台全新安裝 win10 X64 + excel 2019 X64
一台裝了一堆亂七八雜的win7 X64 + excel 2016 X64

使用Microsoft.ACE.OLEDB.12.0開啟access
在不修改、新增程式的情況下，都可正常執行

peter624

5分

1013樓

peter624

個人積分：5分

文章編號：81759991

snare wrote:
沒檔案無法測試您可以(恕刪)

sanre大你好

已解決了，將AccessDatabaseEngine_X64 office2016移除，只重灌 AccessDatabaseEngine_X64 office2010，就可以了，謝謝你的幫忙。

rainbowsperm

0分

1014樓

rainbowsperm

個人積分：0分

文章編號：81823395

snare大神您好
今天用了之前的方法(如下) 好像抓不到資料了? 可能goodinfo又改版了?

https://goodinfo.tw/StockInfo/StockList.asp?RPT_TIME=&MARKET_CAT=熱門排行&INDUSTRY_CAT=投信累計買超金額+–+當日%40%40投信累計買超%40%40投信買超金額+–+當日

我直接用瀏覽器打開也會呈現空白, 但如果在網頁用下拉式選單就會有資料
請問該如何解決這樣的問題, 或是可用下載CSV的方式?

再請指教, 謝謝

Url = "https://goodinfo.tw/StockInfo/StockList.asp?RPT_TIME=&MARKET_CAT=熱門排行&INDUSTRY_CAT=投信累計買超金額+–+當日%40%40投信累計買超%40%40投信買超金額+–+當日"
Url_a = "https://goodinfo.tw/StockInfo/StockList.asp?RPT_TIME=&MARKET_CAT=熱門排行&INDUSTRY_CAT=投信累計買超金額 – 當日@@投信累計買超@@投信買超金額 – 當日"
Call get_goodinfo(Url, Url_a)

Sub get_goodinfo(Url As String, Url_a As String)

Dim Xmlhttp As Object, HTMLsourcecode As Object, Table, i As Integer, p As Integer, ttt As Double

On Error Resume Next

Set HTMLsourcecode = CreateObject("htmlfile")
Set Xmlhttp = CreateObject("WinHttp.WinHttpRequest.5.1")

'Cells.Clear
Application.ScreenUpdating = False

ttt = Timer

ThisWorkbook.Sheets("temp").Cells.Clear

With Xmlhttp
.Open "GET", Url, False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
.send
HTMLsourcecode.body.innerhtml = convertraw(.ResponseBody)

Set Table = HTMLsourcecode.getElementById("tblStockList").Rows
Call Cell_by_Cell("temp", Table)

End With

Application.ScreenUpdating = True

Set HTMLsourcecode = Nothing
Set Xmlhttp = Nothing
Set Table = Nothing

End Sub

snare

2602分

樓主

snare

個人積分：2602分

文章編號：81851442

rainbowsperm wrote:
今天用了之前的方法(如下) 好像抓不到資料了? 可能goodinfo又改版了?

是的，改版了，流量限制，變的非常非常嚴格
連續查5次左右，就檔ip，大約檔30分鐘

單頁資料，勉強可用
多頁資料，反而手動開網頁慢慢下載，還比程式快，多頁建議另找資料來源

'如果您還是有興趣，可參考828樓，20210523，修正的程式碼
'多頁資料，查詢間隔，請自行測試，延遲5秒以上比較安全
'單頁可取消 delaytick 副程式、do ... loop 迴圈

'投信買超金額 – 當日，這頁的資料，程式碼需修改3行



Url = "https://goodinfo.tw/StockInfo/StockList.asp?RPT_TIME=&MARKET_CAT=熱門排行&INDUSTRY_CAT=投信累計買超金額 – 2日@@投信累計買超@@投信買超金額 – 2日"
Url_a = "https://goodinfo.tw/StockInfo/StockList.asp?RPT_TIME=&MARKET_CAT=熱門排行&INDUSTRY_CAT=投信累計買超金額 – 當日@@投信累計買超@@投信買超金額 – 當日"

'=====
.Open "POST", Url, False

'=====
.Open "POST", Url_a, False

'=====
p = Split(HTMLsourcecode.getElementById("selRANK").innertext, "~")(1)
'單頁資料，這行+do loop ，可取消

機八陽

13分

1016樓

機八陽

個人積分：13分

文章編號：81858329

我想問是這樣寫但之前可以顯示~
抓得到~但現在抓不到了~
會顯示空白~
現在要進入頁面後按查詢才能~
要怎麼改程式碼才行呢?

'----------------------------------------------------------------------------------------------------------------------
url = "https://goodinfo.tw/StockInfo/StockList.asp?MARKET_CAT=%E8%87%AA%E8%A8%82%E7%AF%A9%E9%81%B8&INDUSTRY_CAT=%E6%88%91%E7%9A%84%E6%A2%9D%E4%BB%B6&FL_ITEM0=%E9%80%A3%E7%BA%8C%E9%85%8D%E7%99%BC%E5%90%88%E8%A8%88%E8%82%A1%E5%88%A9%E6%AC%A1%E6%95%B8&FL_VAL_S0=7&FL_VAL_E0=&FL_ITEM1=%E7%B4%AF%E5%AD%A3%E2%80%93EPS%E5%B9%B4%E6%88%90%E9%95%B7%E7%8E%87%28%25%29&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=%E5%AD%A3%E7%B4%AF%E8%A8%88%E7%8D%B2%E5%88%A9%E8%83%BD%E5%8A%9B&FL_SHEET2=%E7%8D%B2%E5%88%A9%E8%83%BD%E5%8A%9B&FL_MARKET=%E4%B8%8A%E5%B8%82%2F%E4%B8%8A%E6%AB%83&FL_QRY=%E6%9F%A5++%E8%A9%A2"

Set IE = CreateObject("internetexplorer.application") '使用此方式可以免除 "設定引用項目"
On Error Resume Next
With IE
.Visible = False 'True為開啟ie, False為不開啟ie
.Navigate url
Do While .ReadyState <> 4 '等待網頁開啟
DoEvents
Loop

.ExecWB 17, 2 'Select All
.ExecWB 12, 2 'Copy selection

If Err.Number <> 0 Then Err.Clear: MsgBox "季累計EPS年增率" & vbNewLine & "下載失敗"
End With
'----------------------------------
Sheets("查詢").Range("KA18").Select
ActiveSheet.PasteSpecial Format:="HTML", link:=False, DisplayAsIcon:= _
False, NoHTMLFormatting:=True

IE.Quit
Set IE = Nothing

snare

2602分

樓主

snare

個人積分：2602分

文章編號：81860109

機八陽 wrote:
我想問是這樣寫但之前可以顯示~

這是原本用的程式碼???
第一行就出問題了，您確定可以執行???

網址太長，要分段組合才能使用

url="https://"
url=url & "www.mobile01"
url=url & ".com/"
.........
.........
.........
.Navigate Url

機八陽 wrote:
現在要進入頁面後按查詢才能~



.........
.........
.........
Loop
        .document.all("FL_QRY").Click
        Application.Wait (Now + TimeValue("00:00:15"))

        .ExecWB 17, 2 
        Application.Wait (Now + TimeValue("00:00:15"))

       .ExecWB 12, 2 

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

goldchiou

10分

1018樓

goldchiou

個人積分：10分

文章編號：81864285

Snare大你好,
下圖我嘗試用 Set myo = HTMLsourcecode.getElementsByTagName("td")
i = 5
For Each o In myo
If o.innerText Like "累計下跌幅度" Then
Set mySeco = o.NextSibling
mySeco.Click
End If
Next
點擊選項 "累計下跌幅度"

Set myo = HTMLsourcecode.getElementsByTagName("option")
i = 5
For Each o In myo
If o.innerText Like "當日" Then
Set mySeco = o.NextSibling
mySeco.Click
End If
Next
點擊選項 "當日"

又用
'點選第一層按鈕
'For Each td In .Document.getelementsbytagname("td")
' If td.innertext = "/*S|熱門排行_交易狀況_累計下跌價格@*/color:blue;" Then
' td.Click
' Exit For
' End If
'Next td

' 點選第二層按鈕
'For Each o In .Document.getelementsbytagname("option")
' If a.innertext = "當日" Then
'
' Exit For
' End If
'Next o

不是出現不支援屬性就是不生效，

這是VBA上半部
Sub 跌幅()
Sheets("跌幅").Cells.Clear
Dim Xmlhttp As Object, HTMLsourcecode As Object, Table, Url As String, Url_a As String, i As Integer, p As Integer, ttt As Double, d As String

Set HTMLsourcecode = CreateObject("htmlfile")
Set Xmlhttp = CreateObject("WinHttp.WinHttpRequest.5.1")

Sheets("跌幅").Cells.Clear
Application.ScreenUpdating = False

ttt = Timer

Url = "https://goodinfo.tw/StockInfo/StockList.asp?RPT_TIME=&MARKET_CAT熱門排行&INDUSTRY_CAT=累計下跌幅度 (三年)@@累計下跌幅度@@三年"
Url_a = "https://goodinfo.tw/StockInfo/StockList.asp?%E7%B4%AF%E8%A8%88%E4%B8%8B%E8%B7%8C%E5%B9%85%E5%BA%A6+%28%E7%95%B6%E6%97%A5%29%40%40%E7%B4%AF%E8%A8%88%E4%B8%8B%E8%B7%8C%E5%B9%85%E5%BA%A6%40%40%E7%95%B6%E6%97%A5"
With Xmlhttp
.Open "GET", Url, False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
.send
HTMLsourcecode.body.innerhtml = convertraw(.ResponseBody)

請你指點，如何點擊這兩層?或如何直接到"當日"(我直接用網址到當日，下面的資料是空白的)。
謝謝你!

snare

2602分

樓主

snare

個人積分：2602分

文章編號：81866183

goldchiou wrote:
請你指點，如何點擊這兩層?或如何直接到"當日"(我直接用網址到當日，下面的資料是空白的)。

CreateObject("internetexplorer.application")
才能用點擊的

CreateObject("WinHttp.WinHttpRequest.5.1")
需用
網址+參數
或
網址+send (參數)

'請參考828樓範例
'GET 需改成 POST
'Delaytick(6)，延遲秒數不能太短




Url = "https://goodinfo.tw/StockInfo/StockList.asp?RPT_TIME=&MARKET_CAT=熱門排行&INDUSTRY_CAT=累計下跌幅度 (當日)@@累計下跌幅度@@當日"
Url_a = "https://goodinfo.tw/StockInfo/StockList.asp?SEARCH_WORD=&SHEET=交易狀況&SHEET2=日&MARKET_CAT=熱門排行&INDUSTRY_CAT=累計下跌幅度 (當日)@@累計下跌幅度@@當日&STOCK_CODE=&RPT_TIME=最新資料&STEP=DATA&RANK="
......... 
......... 
......... 

.Open "POST", Url, False

......... 
......... 
.........