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

wkevinst wrote:
最重要的 z 欄位有時候會傳回 - 符號,所以沒辦法推算目前的成交價格
{"queryTime":{"stockInfoItem":198...(恕刪)


沒想到有高手去檢查回傳的json字串

簡單更新一下2017年寫的 twse 範例,請參考219樓、222樓
雖說更新但也沒改什麼,http=>https,順便用on error 處理z的問題

稍微比對一下,開盤、沒開盤,資料有一點點不同
不確定還漏了些什麼,因為我用不到,懶得檢查了
至少9:00~9:30,測試每5秒更新一次,程式還沒出錯
請問snare大大
像這個網址筆數很多
https://isin.twse.com.tw/isin/C_public.jsp?strMode=2
我用webrequest超久
試著用xmlhttp
但是responsetext好像沒要到資料?
請問這個網頁的資料該用什麼方法抓取比較快

謝謝
rainbowsperm wrote:
試著用xmlhttp
但是responsetext好像沒要到資料?(恕刪)


一、使用21樓範例,tags("table")(1)
二、需轉編碼.Charset = "big5"

snare wrote:
一、使用21樓範例,tags...(恕刪)



謝謝snare大神快速的神救援, 已經可以成功了,
不過記得之前有試過table 0-3都不成功, 經過大神一指教就成功了, 真是太奇怪了 哈哈
速度快上許多

感謝大神的幫忙
想請問大家是否有遇到存取被拒的錯誤訊息,
我沒有修改code直接執行下面幾個巨集都會出現相同的error,
是有什麼地方需要做設定嗎?



snare大大你好,先前你開發的資料檔案抓取有出現錯誤,請幫忙再看一下,謝謝


Sub getAllDate()

Dim SCA_DATE, GetXml As Object, list_0, list_1, temp(), r As Integer, stockid As String
Set GetXml = CreateObject("WinHttp.WinHttpRequest.5.1")
'On Error Resume Next
sheets("持股變化").Range("A:Z").Clear
sheets("股東人數").Range("A:Z").Clear
'sheets("存數比例").Columns("A:Z").ClearContents
'sheets("人數").Columns("A:Z").ClearContents
If sheets("工作表1").Cells(1, 1) = "" Then
stockid = InputBox("請輸入證券代號" & vbNewLine & "(輸入後,也可以直接修改a1儲存格)", , "2353")
If stockid = "" Then Exit Sub
sheets("工作表1").Cells(1, 1) = stockid
Else
stockid = sheets("工作表1").Cells(1, 1)
End If
Application.StatusBar = "股號" & stockid
r = 0

With GetXml
.Open "POST", "https://www.tdcc.com.tw/smWeb/QryStockAjax.do", False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.setRequestHeader "Referer", "https://www.tdcc.com.tw/smWeb/QryStock.jsp"
.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
.send "REQ_OPR=qrySelScaDates"

If InStr(.responsetext, "Your request timed out") > 0 Or .responsetext = "[]" Then
Debug.Print "timeout"
DelayTick (100)
r = r + 1
If r > 10 Then
MsgBox "請稍後再試", vbOKOnly, "Error"
Exit Sub
End If
GoTo retry1
End If

SCA_DATE = Split(Replace(Replace(.responsetext, "[", ""), "]", ""), ",")



ReDim temp(UBound(SCA_DATE))
For i = 0 To UBound(SCA_DATE)
temp(i) = Replace(SCA_DATE(i), """", "")
Next i
End With


Set GetXml = Nothing
snare wrote:
xmlhttp 同274...(恕刪)


報告樓主,此程式似已無法使用,.responseText會回傳"{"Error":-3,"Message":"金鑰不正確"}",網址為https://www.cmoney.tw/finance/f00026.aspx?s=3543,可以麻煩樓主協助糾錯嗎?
lujou1 wrote:
先前你開發的資料檔案抓取有出現錯誤,請幫忙再看一下,謝謝(恕刪)


如果是我寫的範例,請告訴我幾樓就好,不要複製一段無法執行的程式碼貼上來
如果是您自己寫的,請上傳可正常執行的程式碼 或 檔案
(如果不想分享功能太完整的程式,請修改成簡化版再上傳)

錯誤原因:網頁改版,請參考686樓

tmwcykixe wrote:
報告樓主,此程式似已無法使用,.responseText會回傳"{"Error":-3,"Message":"金鑰不正確"}",網址為https://www.cmoney.tw/finance/f00026.aspx?s=3543,可以麻煩樓主協助糾錯嗎?(恕刪)


網頁改版
金鑰需轉編碼

請參考269樓(2017-11-15),在程式中加入轉碼的function,在這行下面
cmkey = Right(Split(Split(.responsetext, "'>基本資料<")(1), "'>基本資料<")(0), 24)

多加一行
cmkey = UrlEncode(cmkey)
不好意思,沒有說清楚,真是抱歉抱歉
我是有參照 大大您的程式 去跑
後來發現 原始檔案出錯
大大有做的資料庫版本可以,但小弟才初學淺,參透不出來
我付上大大您之前放上的舊程式
請大大幫忙看看,感謝。

檔案名稱:acer(tdcc)(access)(fix2)

Public Const DBname As String = "stock.accdb"
Global Target As String, Stockid As String, Stockname As String, Use_Combo_Changeid As Boolean


Sub Manually()

Dim LastRow As Integer, online1 As Integer, online2 As Integer, Crange As Range, Combo_Select, idtemp As String

If Use_Combo_Changeid = False Then

LastRow = Sheets("常用股票").Range("a1").CurrentRegion.Rows.Count
If LastRow > 1 Then
Set Crange = Sheets("常用股票").Range("a1", Sheets("常用股票").Range("a1").End(xlDown))
Else
Set Crange = Sheets("常用股票").Range("a1")
End If

idtemp = UCase(InputBox("請輸入證券代號"))
If idtemp = "" Then Exit Sub

If CheckStockId(idtemp) = True Then
Stockid = idtemp
Combo_Select = Application.Match(Stockid, Crange, 0)
If IsError(Combo_Select) Then
LastRow = LastRow + 1
Sheets("常用股票").Cells(LastRow, 1) = Stockid
Combo_Select = LastRow - 1
Else
Combo_Select = Combo_Select - 1
End If
Else
MsgBox "股票代號錯誤,請重新輸入", vbOKOnly, "Error"
Exit Sub
End If
Call AddComboData(LastRow, Combo_Select)

End If


Use_Combo_Changeid = False

With Sheets("工作表1")
.Columns("C:N").ClearContents

Call Get_Offline_Data

If .Cells(2, 3) = "*" And .Cells(2, 8) = "*" Then
Debug.Print "all offline"
Call Get_Offline_Stockname
Else
If .Cells(2, 3) = "" Then online1 = 1 Else online1 = 2
If .Cells(2, 8) = "" Then online2 = 2 Else online2 = 1
If online1 = 1 And online2 = 2 Then Debug.Print "all online" Else Debug.Print "1 online + 1 offline"

Call Get_Online_Data(online1, online2) 'save to access

End If
End With

Call TypeSetting



End Sub


Sub Get_Offline_Data()

ttt = Timer
If Stockid = "" Or Stockid = "股票代號" Then Exit Sub
Dim DB As Object, RS As Object, lastday As String, day(1 To 2) As String, k As Integer, Rsql As String
Set GetXml = CreateObject("WinHttp.WinHttpRequest.5.1")
Set DB = CreateObject("ADODB.Connection")
Set RS = CreateObject("ADODB.Recordset")

DB.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & Target & ";"

Application.ScreenUpdating = False

With Sheets("工作表1")
day(1) = .ListBoxes("list_0").List(.ListBoxes("list_0"))
day(2) = .ListBoxes("list_1").List(.ListBoxes("list_1"))

For k = 1 To 2
Rsql = "SELECT 序,持股,人數,股數,比例 from " & Stockid & " WHERE 日期='" & day(k) & "'"
RS.Open Rsql, DB, 3, 3
Debug.Print RS.RecordCount
If RS.RecordCount <> 0 Then
.Cells(2, 3 + ((k - 1) * 5)) = "*"
.Cells(4, 3 + ((k - 1) * 5)).CopyFromRecordset RS
End If
RS.Close
Next k
End With

With Sheets("工作表1")
.Select
.Cells(2, 4) = day(1)
.Cells(2, 9) = day(2)
End With

DB.Close
Set RS = Nothing
Set DB = Nothing

Debug.Print "Get_Offline_Data", Timer - ttt
Application.ScreenUpdating = True

End Sub


Sub Get_Online_Data(online1 As Integer, online2 As Integer) 'save to access

ttt = Timer

If Stockid = "" Or Stockid = "股票代號" Then Exit Sub

Dim HTMLsourcecode As Object, GetXml As Object, day(1 To 2) As String, DB As Object, sql As String, openDB As String, r As Integer, url_a As String, temp() As String, Combo_Select As Integer, Combo_Text As String
Set HTMLsourcecode = CreateObject("htmlfile")
Set GetXml = CreateObject("WinHttp.WinHttpRequest.5.1")
Set DB = CreateObject("ADODB.Connection")
openDB = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & Target & ";"
DB.Open openDB


On Error GoTo redownload

Application.ScreenUpdating = False

day(1) = Sheets("工作表1").ListBoxes("list_0").List(Sheets("工作表1").ListBoxes("list_0"))
day(2) = Sheets("工作表1").ListBoxes("list_1").List(Sheets("工作表1").ListBoxes("list_1"))

For k = online1 To online2
r = 0
retry2:
url_a = "scaDates=" & day(k) & "&scaDate=" & day(k) & "&SqlMethod=StockNo&StockNo=" & Stockid & "&radioStockNo=" & Stockid & "&StockName=&REQ_OPR=SELECT&clkStockNo=" & Stockid & "&clkStockName="

With GetXml
.Open "POST", "https://www.tdcc.com.tw/smWeb/QryStockAjax.do", False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.setRequestHeader "Referer", "http://www.tdcc.com.tw/smWeb/QryStock.jsp"
.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
.send url_a

HTMLsourcecode.body.innerhtml = .responsetext

If InStr(HTMLsourcecode.body.innerhtml, "Your request timed out") > 0 Then
Debug.Print "timeout"
Delaytick (0.05)
r = r + 1
If r > 10 Then
MsgBox "請稍後再試", vbOKOnly, "Error"
Exit Sub
End If
GoTo retry2
End If

Stockname = Split(HTMLsourcecode.all.tags("table")(6).Rows(0).innertext, "資料日期")(0)
Set Table = HTMLsourcecode.all.tags("table")(7).Rows

If Table(1).Cells(0).innertext = "無此資料" Then
Delaytick (0.05)
r = r + 1
If r > 10 Then
MsgBox day(k) & "此日期無資料", vbOKOnly, "Error"
If day(1) <> day(2) Then
sql = "INSERT INTO " & Stockid & _
" (日期,序,持股) VALUES " & _
"('" & day(k) & "','" & "1" & "','" & "無此資料" & "')"
DB.Execute sql
End If
GoTo getnextday
End If
GoTo retry2
End If

ReDim temp(1 To Table.Length - 1, Table(2).Cells.Length - 1)

With Sheets("工作表1")

For i = 1 To Table.Length - 1

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

If day(1) <> day(2) Then

sql = "INSERT INTO " & Stockid & _
" (日期,序,持股,人數,股數,比例) VALUES " & _
"('" & day(k) & "','" & temp(i, 0) & "','" & temp(i, 1) & "','" & temp(i, 2) & "','" & temp(i, 3) & "','" & temp(i, 4) & "')"
DB.Execute sql
End If
Next i
.Range(.Cells(4, 3 + ((k - 1) * 5)), .Cells(i + 2, 7 + ((k - 1) * 5))) = temp()

End With

End With
getnextday:
Next k

With Sheets("工作表1")
.Select
.Cells(2, 4) = day(1)
.Cells(2, 9) = day(2)
End With

DB.Close
Set DB = Nothing
Set Table = Nothing
Set HTMLsourcecode = Nothing
Set GetXml = Nothing
Application.ScreenUpdating = True

Debug.Print Timer - ttt
Exit Sub

redownload:
r = r + 1
Debug.Print "http 404"
Delaytick (0.05)
If r > 10 Then
MsgBox "連線異常,請稍後再試", vbOKOnly, "Error"
Exit Sub
End If
GoTo retry2

If Err.Number <> 0 Then
Debug.Print Err.Description
End If


End Sub

Sub TypeSetting()

Application.ScreenUpdating = False
With Sheets("工作表1")
.Select
.Range("c3:n3") = Array("序", "持股", "人數", "股數", "比例%", "序", "持股", "人數", "股數", "比例%", "人數變化", "股數變化")
.Cells(4, 13).FormulaR1C1 = "=RC[-3]-RC[-8]"
.Cells(4, 14).FormulaR1C1 = "=RC[-3]-RC[-8]"
.Range("M4:N4").AutoFill Destination:=Range("M4:N18"), Type:=xlFillDefault
.Range("C3:N25").HorizontalAlignment = xlRight
.Range("D3:D25,I3:I25").HorizontalAlignment = xlLeft

Call SetFormatCondition

.Cells.Font.Size = "10"
.Columns.AutoFit
.Columns("A:B").ColumnWidth = 15
.Columns("M:N").NumberFormatLocal = "#,##0_ "
.Range("c:c,h:h").ColumnWidth = 3
.Range("d:d,i:i").ColumnWidth = 18
.Range("e:e,j:j").ColumnWidth = 10
.Range("f:f,k:k").ColumnWidth = 15
.Range("g:g,l:l").ColumnWidth = 6


.Cells(1, 4) = Stockname ' debug
.Cells(1, 1).Select

End With
Application.ScreenUpdating = True


End Sub

Sub Get_Offline_Stockname()


ttt = Timer

Dim DB As Object, RS As Object
Set DB = CreateObject("ADODB.Connection")
Set RS = CreateObject("ADODB.Recordset")

DB.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & Target & ";"
RS.Open "SELECT 代號,名稱 FROM 股票清單 WHERE 代號='" & Stockid & "'", DB, 3, 3
Stockname = "證券代號:" & RS.Fields(0) & " 證券名稱:" & RS.Fields(1)

RS.Close
DB.Close
Set RS = Nothing
Set DB = Nothing

Debug.Print "get_offline_stockname", Timer - ttt

End Sub

Function CheckStockId(id As String) As Boolean

ttt = Timer

Dim DB As Object, RS As Object
Set DB = CreateObject("ADODB.Connection")
Set RS = CreateObject("ADODB.Recordset")


DB.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & Target & ";"
RS.Open "SELECT 代號,名稱 FROM 股票清單 WHERE 代號='" & UCase(id) & "'", DB, 3, 3

If RS.RecordCount = 0 Then
CheckStockId = False
Debug.Print "無此代號", Timer - ttt
Stockname = ""
Else
CheckStockId = True
Debug.Print "代號正確", Timer - ttt
Stockname = "證券代號:" & RS.Fields(0) & " 證券名稱:" & RS.Fields(1)

End If

RS.Close
DB.Close
Set RS = Nothing
Set DB = Nothing

Debug.Print "checkstockid", Timer - ttt

End Function


Sub SetFormatCondition()

Dim Crange As Range, C1 As FormatCondition, C2 As FormatCondition
Set Crange = Sheets("工作表1").Range("m4", Sheets("工作表1").Range("n4").End(xlDown))
Crange.FormatConditions.Delete
Crange.Font.Bold = True
Set C1 = Crange.FormatConditions.Add(xlCellValue, xlGreater, "=0")
C1.Font.Color = vbRed
Set C2 = Crange.FormatConditions.Add(xlCellValue, xlLess, "=0")
C2.Font.Color = -11489280
Set Crange = Nothing

End Sub


Sub addlistbox()

ttt = Timer
Dim DB As Object, RS As Object, lastday As String, list_0, list_1, Combo_0, temp()
Set DB = CreateObject("ADODB.Connection")
Set RS = CreateObject("ADODB.Recordset")
On Error Resume Next

Sheets("工作表1").Columns("C:N").ClearContents
Application.ScreenUpdating = False

DB.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & Target & ";"
RS.Open "select 日期 from 日期清單 order by 日期 desc", DB, 3, 3
temp = RS.getrows

With Sheets("工作表1")
.Select
.Shapes.Range(Array("List_0", "List_1", "Combo_0")).Delete
.Cells.Clear

Set list_0 = .ListBoxes.Add(.Range("a3").Left + 1, .Range("a3").Top, 82, 400)
Set list_1 = .ListBoxes.Add(.Range("b3").Left + 1, .Range("b3").Top, 82, 400)
Set Combo_0 = .Shapes.AddFormControl(xlDropDown, .Range("a1").Left, .Range("a1").Top, 86, 15)
With list_0
.Name = "list_0"
list_0.List = temp()
.Selected(2) = True
.OnAction = "Listbox_Change"
End With
With list_1
.Name = "list_1"
list_1.List = temp()
.Selected(1) = True
.OnAction = "Listbox_Change"
End With

With Combo_0
.Name = "Combo_0"
.ControlFormat.DropDownLines = 10
Sheets("常用股票").Range("a1") = "股票代號"
Call AddComboData(0, 1)
.OnAction = "Combo_0_Change"
End With
If Stockid = "" Then Stockid = .Shapes("combo_0").ControlFormat.List(1)

.Cells.Font.Size = "10"
.Columns.AutoFit
.Columns("A:B").ColumnWidth = 15
.Cells(1, 1).Select
End With

Application.ScreenUpdating = True

Debug.Print "表單物件" & Sheets("工作表1").Shapes.Count, "default stockid=" & Stockid
Erase temp
RS.Close
DB.Close
Set RS = Nothing
Set DB = Nothing


End Sub
Sub Listbox_Change()

Dim LastRow As Integer
LastRow = Sheets("常用股票").Range("a1").CurrentRegion.Rows.Count

If Stockid <> "股票代號" And LastRow > 1 Then
Use_Combo_Changeid = True
Call Manually
End If

End Sub

Sub Combo_0_Change()

Dim Combo_Select As Integer, LastRow As Integer
LastRow = Sheets("常用股票").Range("a1").CurrentRegion.Rows.Count

With Sheets("工作表1")
Combo_Select = .Shapes("combo_0").ControlFormat.Value
Stockid = .Shapes("combo_0").ControlFormat.List(Combo_Select)
Debug.Print Stockid
End With

If Stockid <> "股票代號" And LastRow > 1 Then
Use_Combo_Changeid = True
Call Manually
End If
End Sub

Sub AddComboData(LastRow As Integer, Combo_Select)

Dim Combo_Range As String

If LastRow = 0 Then
LastRow = Sheets("常用股票").Range("a1").CurrentRegion.Rows.Count
Combo_Range = "常用股票!$A$2:$A$" & LastRow
End If
If LastRow = 1 Then
Combo_Range = "常用股票!$A$1:$A$" & LastRow
End If
If LastRow > 1 Then
Combo_Range = "常用股票!$A$2:$A$" & LastRow
End If

With Sheets("工作表1")
.Shapes("combo_0").ControlFormat.ListFillRange = Combo_Range
.Shapes("combo_0").ControlFormat.Value = Combo_Select
End With


End Sub



Sub Update_TDCC_day()


ttt = Timer

Dim GetXml As Object, DB As Object, RS As Object, r As Integer, TDCC_day() As String, a As Integer, d As Integer
Set GetXml = CreateObject("WinHttp.WinHttpRequest.5.1")
Set DB = CreateObject("ADODB.Connection")
Set RS = CreateObject("ADODB.Recordset")
DB.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & Target & ";"

On Error Resume Next
r = 0
retry1:
With GetXml
.Open "POST", "https://www.tdcc.com.tw/smWeb/QryStockAjax.do", False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.setRequestHeader "Referer", "https://www.tdcc.com.tw/smWeb/QryStock.jsp"
.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
.send "REQ_OPR=qrySelScaDates"

If InStr(.responsetext, "Your request timed out") > 0 Or .responsetext = "[]" Then
Debug.Print "timeout"
Delaytick (0.01)
r = r + 1
If r > 10 Then
MsgBox "日期無法更新,請稍後再試", vbOKOnly, "Error"
Exit Sub
End If
GoTo retry1
End If


TDCC_day = Split(Replace(Replace(Replace(.responsetext, "[", ""), "]", ""), """", ""), ",")

For i = 0 To UBound(TDCC_day)
RS.Open "SELECT 日期 FROM 日期清單 WHERE 日期='" & TDCC_day(i) & "'", DB, 3, 3
If RS.RecordCount = 0 Then
'Debug.Print "新增日期", TDCC_day(i), RS.RecordCount
DB.Execute = "INSERT INTO 日期清單 (日期) VALUES ('" & TDCC_day(i) & "')"
a = a + 1
Else
'"日期重覆"
d = d + 1
End If
RS.Close
Next i

End With


DB.Close
Set RS = Nothing
Set DB = Nothing
Set GetXml = Nothing

Debug.Print "Update_TDCC_day", "新增" & a, "重覆" & d, Timer - ttt

End Sub


Sub Checkdb_GetPath()

Target = ThisWorkbook.Path & "\" & DBname

If Dir(Target) <> "" Then
Debug.Print "db ready"
Use_Combo_Changeid = True
Else
MsgBox "資料庫不存在,程式結束"
Application.DisplayAlerts = False
Application.Quit
ThisWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True
End If

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
抱歉 大大 問題解決了 驚動到您了,抱歉抱歉
關閉廣告

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

文章分享
評分
複製連結
請輸入您要前往的頁數(1 ~ 124)