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

Dylan67 wrote:
想請教271F的這張圖是什麼用[下載軟體]截屏的,我找不到相符的畫面,
用GoogleF12及Fiddler也找不到這個網址Key,


網頁某天改版了,不會顯示key
因271樓範例可正常執行,懶的改了



Dylan67 wrote:
再請教,272F批量下載的CSV若想改存在Access,是不是只能一個一個在Excel[不存檔直接開啟後]→再用ADO存入Access,您方便給點提示嗎?感謝


如果要用ado,是的(一格、一列、一欄、一個範圍,都可以)


整個檔案匯入,可用CreateObject("Access.Application")
單檔案”匯入範例,請參考

'測試前excel需先存檔一次,ThisWorkbook.Path,才會有資料
Sub Csv_to_Access_Test()

Dim cta As Object, TestFile_Name As String
Set cta = CreateObject("Access.Application")

TestFile_Name = "2412.csv" '檔名只能有一個點. , .tw.csv 不行

cta.Visible = True
'需先用access建立一個名稱為test的空白資料庫
cta.OpenCurrentDatabase ThisWorkbook.Path & "\test.accdb", True

'多檔案匯入迴圈開始位置

cta.docmd.TransferText acImportDelim, , Replace(TestFile_Name, ".csv", ""), ThisWorkbook.Path & "\" & TestFile_Name, True
'只要csv檔案內有空白資料,使用整個檔案匯入的方式,access一定會產生,"檔名_匯入錯誤"的表格
'通常是刪掉,但不理它也行
'(舊版access不確定是不是這種命名方式,請自行修改)

cta.docmd.deleteobject actable, Replace(TestFile_Name, ".csv", "") & "_匯入錯誤"


'多檔案匯入迴圈結束位置

cta.Quit
Set cta = Nothing

End Sub


取得目錄下多個檔案名稱,最近有回答類似的問題,可參考
2020-10-11
https://www.mobile01.com/topicdetail.php?f=511&t=6209216&p=3#79367953
2020-09-21
https://www.mobile01.com/topicdetail.php?f=511&t=6187820&p=4#79148485
2020-09-17
https://www.mobile01.com/topicdetail.php?f=511&t=6191653

google dir() vba
271F的Url="...events=history&crumb=",變成events="...history&includeAdjustedClose=true",

少了Key,Yahoo真是佛心來著,代碼變的相當簡單,如版主所說,不改也能下載。

Set cta = CreateObject("Access.Application") CSV直存Access真是太厲害,歎為觀止,仰天長嘯,

不過資料要處理成資訊才有價值,我只能[不存打開處理後再存],也就心滿意足了。

244F股權分散表經您提點,已有了些許突破,但革命尚未成功,尚待繼續努力…

另想再請教您2個[遍歷單元格範圍]關鍵字的問題,

我Google及百度了一整天,不外乎一個一個查找單元格及先存入陣列2種方式,

想請教您有沒有更好的方法,如下圖:



我自己寫了陣列代碼(And、And、And...無限And,但處理速度很慢,我覺得應該不是這樣),



問題1:[清除]關鍵字所在的行,並將其餘數據行向上填充

問題2:查找關鍵字所在的行,並取得A列的行[標題]

再次感謝您的不吝指導
Dylan67 wrote:
問題1:[清除]關鍵字所在的行,並將其餘數據行向上填充

問題2:查找關鍵字所在的行,並取得A列的行[標題]


雖然我知道您要問什麼
但請先修正您的問題(包括程式碼中的註解)
能正確發問後,我再回答
非常感謝版主的回覆,

您大概是看到我代碼中And、And、And...........的錯誤,

附件我完善了按鍵、代碼及注釋,所提的問題也可實現(2個問題是1個問題),

就是在遍歷單格範圍關鍵字時,我的判斷語句會變的很長(如下圖),



但Google及百度找來找去都是類似的方法(遍歷單元格、遍歷陣列、還有一種就是每列篩選),

所以想請教您,是否有更理想的方法,致敬。

[點擊下載]
Dylan67 wrote:
您大概是看到我代碼中And、And、And...........的錯誤,


唉~程式碼有沒有錯,我根本不介意,本來就不會才會發問不是嗎,有錯很正常
您把最基本的列、欄,搞錯了,922樓程式碼的註解是錯的
雖然您自己知道正確的位置,但看的人不小心會被誤解
excel列、欄,搞相反,得到會是完全不同的答案

横的為列row,直的為欄column
(補充:好奇改用百度搜尋發現大陸有些教學是用直行横列,沒有欄,剛好相反)
(在01問的話,建議用列、欄,或是直接用英文row、column)

要改成這樣問,才正確

問題1:[清除]關鍵字所在的,並將其餘數據行向上填充
問題2:查找關鍵字所在的,並取得對應該列的A欄[標題]

您的寫法可以用,也不慢,問題1+問題2,執行時間約0.25~0.3秒
就是if太長

另一種寫法,請參考,相同資料量,問題1+問題2,執行時間約0.06~0.09秒




Sub test()

Dim Del_data As String, temp As String, del_row As Range, Row_number, Source As Range, Find_String, i As Integer
Dim Col_a_name As String, ttt As Double, total As Integer

ttt = Timer
Application.ScreenUpdating = False

Set Source = Sheets("計算").Range("b1:z1000") '資料範圍,不含a欄
Del_data = "DEF,GHI" '增加搜尋字串時,需用逗點“,”隔開字串
Find_String = Split(Del_data, ",")

For i = 0 To UBound(Find_String)
temp = temp & "," & Found_Range(Source, CStr(Find_String(i)))
Next i

Row_number = Split(temp, ",")

For i = 0 To UBound(Row_number)
If Row_number(i) <> "" Then
total = total + 1 'debug
Col_a_name = Col_a_name & "," & Sheets("計算").Cells(Row_number(i), 1)
If del_row Is Nothing Then
Set del_row = Sheets("計算").Rows(Row_number(i))
Else
Set del_row = Union(del_row, Sheets("計算").Rows(Row_number(i)))
End If
End If
Next i

'If Not del_row Is Nothing Then del_row.Interior.Color = vbGreen 'debug
'stop
'Call Count_row(del_row) 'debug
'stop

If Not del_row Is Nothing Then del_row.Delete
Application.ScreenUpdating = True

Debug.Print Timer - ttt & "秒"
MsgBox Col_a_name

End Sub


Function Found_Range(Source As Range, Find_what As String) As String

Dim First_Found_Cell_Address As String, Found_cell As Range, temp As Range
Set Found_cell = Source.Find(Find_what, LookIn:=xlValues)

If Not Found_cell Is Nothing Then
First_Found_Cell_Address = Found_cell.Address
Else
'"nothing found"
Exit Function
End If

'Found_Range = Found_cell.Address
Found_Range = Found_cell.Row
Do Until Found_cell Is Nothing
Set Found_cell = Source.FindNext(Found_cell)
If Found_cell.Address = First_Found_Cell_Address Then Exit Do
'Found_Range = Found_Range & "," & Found_cell.Address

Found_Range = Found_Range & "," & Found_cell.Row
Loop

End Function


Sub Count_row(Source As Range)
For i = 1 To Source.Areas.Count
r = r + Source.Areas(i).Rows.Count
Next i
Debug.Print r & "row,del"
End Sub




謝謝您的提醒,應該懂您要表達的意思,

就是要先查找關鍵字所在單元格的(列,欄),

然後刪除該單元格所在的[列],或取得A欄所對應的[列標],

抱歉描述問題不清楚,造成可能誤解,

也感謝您的快速回覆,果然,是有更高效的方法,

我繼續學習,有問題再向您求教。
snare大神, 又來跟您求救啦

有兩個問題想請教一下
1. https://goodinfo.tw/StockInfo/ShowSaleMonChart.asp?STOCK_ID=2002
我想抓中間表格的資料XXXX 年 X 月 份 營 收 統 計
我看HTML source code的部分有看到關鍵字所以試著想用Set Table = HTMLsourcecode.getElementsByClassName("solid_1_padding_4_0_tbl")
但一直抓不到資料 請問是哪裡出錯??

2.https://mops.twse.com.tw/mops/web/t163sb19
像這個查詢結果有很多個table, 是否只能用loop來實現??
要如何偵測最後一個table??


在煩請撥空指導

謝謝
rainbowsperm wrote:
1. Set Table = HTMLsourcecode.getElementsByClassName("solid_1_padding_4_0_tbl")
但一直抓不到資料 請問是哪裡出錯??


rainbowsperm wrote:
2.https://mops.twse.com.tw/mops/web/t163sb19
像這個查詢結果有很多個table, 是否只能用loop來實現??
要如何偵測最後一個table??


1、2,都可用778樓範例解決,Get or Post、Send 參數,請自行練習
(twse有下載csv檔按鈕,相關範例,請參考其它樓層)



snare wrote:
https://mops.twse.com.tw/mops/web/t163sb19


謝謝大大 已成功
有時候太執著特定寫法 導致腦經打結~~XD
其實都跟之前一樣的方法~~~><
Snare大你好,
你的發文我從頭看到尾,你的功力與熱心,我不能說再多了,今天有一問題,修改了很久,實在不得已,想請你指點,謝謝你!
Sub test()

Cells.Clear


Dim t: t = Timer

With myXML
.Open "GET", "https://www.wantgoo.com/stock/astock/agentstat2?stockno=8069" , False
.send
myHTML.body[removed] = .responseText

Set myTable = myHTML.getElementsByTagName("table")(0)

ReDim myArr(1 To myTable.Rows.Length, 1 To myTable.Rows(0).Cells.Length)

i = 1
For Each myRow In myTable.Rows
j = 1
For Each myCell In myRow.Cells
myArr(i, j) = myCell.innerText
j = j + 1
Next
i = i + 1
Next

End With

Range("A3").Resize(UBound(myArr, 1), UBound(myArr, 2)).Value = myArr
Set myXML = Nothing
Set myHTML = Nothing
Erase myArr

Range("A2") = stockno
Application.StatusBar = "下載完畢,共花了" & Format(Timer - t, "0.00秒")

End Sub

跑出來只有 日期 收盤價 買賣超 家數差 5日集中 20日集中

謝謝你!
關閉廣告
文章分享
評分
評分
複製連結
請輸入您要前往的頁數(1 ~ 143)

今日熱門文章 網友點擊推薦!