我採用了1173樓的手法，得到了想要的資料，
但，如你所知，原始資料就會有一列資料一列空白，
有辦法快速消掉那一列列的空白ROW嗎?
我採用了以下方法，
一.
Range("a:a").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
二.
Sheets(3).Select
For i = 3 To 200
Rows(i).Select
Selection.Delete
Next
三.
For DQ = 1 To 110
If Range("a" & DQ) = "" Then
Rows(DQ).Select
Selection.Delete
DQ = DQ - 1
Else: End If
Next
發現效果都一樣，每消掉一個ROW都要花掉近一秒，不曉得是否有其他手法可快速消掉空白ROW，
不然，就要與他和平共處了。
謝謝指導~~
cji3cj6xu6 wrote:
發現效果都一樣，每消掉一個ROW都要花掉近一秒，不曉得是否有其他手法可快速消掉空白ROW，
Sub test1()
Dim i As Double, ttt As Double, b As Double
b = rnd_blank_data
'debug
MsgBox b & " blank test data" & vbNewLine & " start test"
ttt = Timer
Application.ScreenUpdating = False
Range("a:a").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
ttt = Timer - ttt
'debug
MsgBox "test1" & vbNewLine & WorksheetFunction.CountA(Range("a1:a60000")) & " data" & vbNewLine & _
b & " blank test data" & vbNewLine & _
ttt & "s"
End Sub
Sub test2()
Dim i As Double, ttt As Double, b As Double
b = rnd_blank_data
'debug
MsgBox b & " blank test data" & vbNewLine & " start test"
ttt = Timer
Application.ScreenUpdating = False
For i = 60000 To 1 Step -1
If Sheets("工作表1").Cells(i, 1) = "" Then Sheets("工作表1").Rows(i).Delete Shift:=xlUp
Next
Application.ScreenUpdating = True
ttt = Timer - ttt
'debug
MsgBox "test2" & vbNewLine & WorksheetFunction.CountA(Range("a1:a60000")) & " data" & vbNewLine & _
b & " blank test data" & vbNewLine & _
ttt & "s"
End Sub
Sub test3()
Dim i As Double, j As Double, r As Double, ttt As Double, b As Double, alldata, temp(1 To 60000, 1 To 3)
b = rnd_blank_data
'debug
MsgBox b & " blank test data" & vbNewLine & " start test"
ttt = Timer
Application.ScreenUpdating = False
alldata = Sheets("工作表1").Range("a1:c60000")
For i = 1 To UBound(alldata)
If alldata(i, 1) <> "" Then
r = r + 1
For j = 1 To UBound(alldata, 2)
temp(r, j) = alldata(i, j)
Next j
End If
Next
Sheets("工作表1").Range("a1:c60000") = temp()
Application.ScreenUpdating = True
ttt = Timer - ttt
'debug
MsgBox "test3" & vbNewLine & WorksheetFunction.CountA(Range("a1:a60000")) & " data" & vbNewLine & _
b & " blank test data" & vbNewLine & _
ttt & "s"
End Sub
'rnd test data
Function rnd_blank_data() As Double
Dim i As Double
Application.ScreenUpdating = False
Cells.Clear
For i = 1 To 60000
If Application.RandBetween(1, 60) <> Int(i / 1000) Then
Cells(i, 1) = Application.RandBetween(1, 10000)
Cells(i, 2) = Application.RandBetween(1, 10000)
Cells(i, 3) = Application.RandBetween(1, 10000)
End If
Next i
Application.ScreenUpdating = True
rnd_blank_data = WorksheetFunction.CountBlank(Range("a1:a60000"))
End Function
cji3cj6xu6 wrote:
發現效果都一樣，每消掉一個ROW都要花掉近一秒，不曉得是否有其他手法可快速消掉空白ROW，
cji3cj6xu6 wrote:
時間沒有太多的改變，八成是我的PC的問題
那就沒辦法了，您才幾百筆的資料，刪1個row要1秒，時間太奇怪
下面是我測試3種刪除方式(1182樓)的使用時間(不含產生隨機資料的時間)
隨機資料6萬筆(含隨機約1千個空白列)
如果改成隨機資料300筆(含隨機約10個空白列)
基本上都是瞬間完成
test3 因為資料量太少，dim as double+時間太短，時間無法正確顯示
所以一開始才會用6萬筆測試，而不是用幾百筆
可以用StrConv(TempArray(0, 0), vbNarrow)去轉成半形再Split
test = Split(Replace(Replace(Replace(StrConv(TempArray(0, 0), vbNarrow), Chr(32), "@"), Chr(10), "@"), Chr(13), "@"), "@")
"如你所知，原始資料就會有一列資料一列空白，有辦法快速消掉那一列列的空白ROW嗎?"就是你說的有一列空白，我發現是有全形的空白你用這行看看，看那行會不會不見
想請教一下，我試了https://stocks.ddns.net/TW.aspx這個網站
想載入「(7)預期報酬率大於18%」的股票，但怎麼抓都只抓到首頁的資料
想請教從那邊可以看到傳送指令的部份，又要麻煩你指導一下了，謝謝
Sub MyStock()
Dim A As Object, xDate As Date, EDATE As Date
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Visible = False
.Navigate "https://stocks.ddns.net/TW.aspx?ctl00_ContentPlaceHolder1_rblstock=H&ctl00_ContentPlaceHolder1_ddlROI=18"
Do While .Busy Or .readyState <> 4: DoEvents: Loop
End With
MyFunction
End Sub
Private Sub MyFunction()
Dim A As Object, K As Integer, i As Integer, ii As Integer
With IE
Do While .Busy Or .readyState <> 4: DoEvents: Loop
Set A = .document.getElementsByTagName("table")(2)
End With
With ActiveSheet
.UsedRange.Clear
K = 1
For i = 0 To A.Rows.Length - 1
For ii = 0 To A.Rows(i).Cells.Length - 1
.Cells(K, ii + 1) = A.Rows(i).Cells(ii).INNERTEXT
Next
K = K + 1
Next
End With
IE.Quit
End Sub
dolter29 wrote:
想請教從那邊可以看到傳送指令的部份
您貼出來的程式碼是錯的，連首頁資料都抓不到，我不清楚為什麼您還能抓到資料
請自行修正錯誤的地方
使用CreateObject("InternetExplorer.Application")
如果直連網址還看不到想要的資料，那就要改用點擊網頁方式改變選項
ie按鈕，要看網頁設計，有很多種可用的方式
這個網頁，可用645樓範例、方法2(非本地端網頁ie不用改activex設定)
'………
'…略…
'………
.Visible = True
.Navigate "https://stocks.ddns.net/TW.aspx"
Do While .Busy Or .readyState <> 4: DoEvents: Loop
Set DOM_event = .document.createEvent("HTMLEvents")
DOM_event.initEvent "change", True, False
.document.getElementById("ctl00_ContentPlaceHolder1_rblstock").Focus
.document.getElementById("ctl00_ContentPlaceHolder1_rblstock").selectedindex = 6 '(7)預期報酬率大於
.document.getElementById("ctl00_ContentPlaceHolder1_rblstock").dispatchEvent DOM_event
Application.Wait (Now + TimeValue("00:00:05"))
.document.getElementById("ctl00_ContentPlaceHolder1_ddlROI").Focus
.document.getElementById("ctl00_ContentPlaceHolder1_ddlROI").selectedindex = 10 '18%
.document.getElementById("ctl00_ContentPlaceHolder1_ddlROI").dispatchEvent DOM_event
Application.Wait (Now + TimeValue("00:00:05"))
'………
'…略…
'………
tmwcykixe wrote:
1059樓似乎又不能使用，懇請協助查看.
(2022/01/05 20:10) 我試是正常的
tmwcykixe wrote:
另請教https://www.wantgoo.com/stock/2330/technical-chart
應如何抓取完整之還原月線資料(開、高、低、收等)。
建議改去 finance.yahoo.com 抓資料(271、272、274樓)
wantgoo很多網頁慢慢的加上防爬蟲，範例可能很快就不能用了
簡易範例如下，請參考
Sub wantgoo_historical()
Dim Xmlhttp As Object, Jsondata As Object, UrL As String, UrL_a As String, DecodeJson, ttt As Double, Stock As String
Dim temp, acts, periods, reports, reportdate As String, i As Integer, j As Integer, lastrow As Double
Set Xmlhttp = CreateObject("msxml2.xmlhttp")
Application.ScreenUpdating = False
ttt = Timer
Stock = "2330" 'test top=490 top=60
'Stock = "2002" 'test top=490 top=60
'Stock = "2412" 'test top=60
UrL = "https://www.wantgoo.com/investrue/" & Stock & "/historical-daily-candlesticks?before=" & UnixTime & "&top=490"
UrL_a = "https://www.wantgoo.com/stock/" & Stock & "/technical-chart"
With Xmlhttp
.Open "GET", UrL, False
.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/92.0.4515.107 Safari/537.36"
.setRequestHeader "Referer", UrL_a
.send
Set DecodeJson = Jsondata.JsonParse(.responsetext)
With Sheets("工作表1")
.Cells.Clear
.Range("a1:g1") = Array("time", "high", "low", "millionAmount", "open", "close", "volume")
For i = 0 To CallByName(DecodeJson, "length", VbGet) - 1
Set temp = CallByName(DecodeJson, i, VbGet)
.Cells(i + 2, 1) = Format(CallByName(temp, "time", VbGet) / 86400000 + #1/1/1970 8:00:00 AM#, "yyyy/mm/dd")
.Cells(i + 2, 2) = CallByName(temp, "close", VbGet)
.Cells(i + 2, 3) = CallByName(temp, "high", VbGet)
.Cells(i + 2, 4) = CallByName(temp, "low", VbGet)
.Cells(i + 2, 5) = CallByName(temp, "millionAmount", VbGet)
.Cells(i + 2, 6) = CallByName(temp, "open", VbGet)
.Cells(i + 2, 7) = CallByName(temp, "volume", VbGet)
Next i
.Columns.AutoFit
End With
Application.ScreenUpdating = True
Debug.Print Timer - ttt
End With
Set GetXml = Nothing
Set Jsondata = Nothing
Set DecodeJson = Nothing
Set temp = Nothing
End Sub
Function UnixTime() As String
UnixTime = (Date - #1/1/1970 8:00:00 AM#) * 86400000
End Function
snare wrote:
(2022/01/05(恕刪)
感謝樓主迅速的回復,
不好意思,我是指1059樓-抓取wantgoo主力買賣超這個程式.
另這個網頁https://www.wantgoo.com/stock/2330/technical-chart
是想請教您還原月線的部份，Request URL應該是這個: https://www.wantgoo.com/investrue/2330/historical-retro-monthly-candlesticks?before=1635696000000，但此url只有前3個月以前的資料，近3個月的資料在https://www.wantgoo.com/investrue/2330/retro-monthly-candlesticks?after=1633017600000。小弟功力不夠，無法抓到近3個月這筆。
雖然yahoo也有還原後的數值，但經比對後，那值非正確。
故再請您協助解惑。
內文搜尋
從 APP 打開
X