野比大雄1 wrote:
請問合計買賣超部分怎...(恕刪)
1369樓第2張圖的程式碼，就是方法，但資料請自行練習整理。
個人積分：3127分
文章編號：88905179
個人積分：0分
文章編號：88905391
個人積分：3127分
文章編號：88906471
個人積分：0分
文章編號：88908133
野比大雄1 wrote:
請問這資料怎麼抓取，...(恕刪)
您好:
我發現會沒有 -負號 再麻煩您謝謝
Sub c()
Dim URL As String, GetXml As Object
URL = "https://tw.stock.yahoo.com/quote/" & Sheets("stock").Cells(i, 1) & ".TW/broker-trading"
Set GetXml = CreateObject("WinHttp.WinHttpRequest.5.1")
With GetXml
.Open "GET", URL, False
.setRequestHeader "Cache-Control", "no-cache"
.setRequestHeader "Pragma", "no-cache"
.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
.send
temp = Split(Split(.responsetext, """totalOversellVolK"":")(1), ",""tradeVolumeRate""")(0)
End With
Set GetXml = Nothing
Set Jsondata = Nothing
End Sub
個人積分：0分
文章編號：88923787
Sub 巨集2()
'
' 巨集2 巨集
'
Dim Http As Object
Dim Username As String, Password As String
Dim Url As String, Data As String
' 設定帳號和密碼
Username = "***@gmail.com"
Password = "***"
' 設定目標網頁的URL和POST資料
Url = "https://thefew.tw/login"
Data = "username=" & Username & "&password=" & Password
' 建立XMLHttpRequest物件
Set Http = CreateObject("MSXML2.XMLHTTP")
' 設定請求參數
Http.Open "POST", Url, False
Http.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
' 傳送請求
Http.send Data
' 檢查回應狀態碼，如果是200表示登入成功
If Http.Status = 200 Then
' 登入成功後，您可以使用XMLHttpRequest物件下載所需的資料
' ...
Else
MsgBox "登入失敗"
End If
' 設定帳號和密碼
With ActiveSheet.QueryTables.Add(Connection:="URL;https://thefew.tw/cb", _
Destination:=Range("$A$1"))
' .CommandType = 0
.Name = "cb"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlAllTables
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
End Function
個人積分：3127分
文章編號：88930571
個人積分：0分
文章編號：88959323
很抱歉，操作錯誤。
個人積分：0分
文章編號：88965936
出遊之前就參考#223樓將上櫃股票每日收盤價QT改成 XmlHttp，一個多月下來竟然覺得生疏了很多。測試的結果，測試工作表上竟然是空白，一筆資料都沒有。我也看不出所以然，請大師抽空提點一下，謝謝。完整程式碼如下：
Sub GettpexHtml()
'Html下載測試_上櫃股票每日收盤行情
Dim HTMLsourcecode As Object, Clipboard As Object, XmlHttp As Object
Dim Url As String, Urla As String, stock_id As String
Dim formattedDate As String ' 日期字串
Set HTMLsourcecode = CreateObject("htmlfile")
Set Clipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
Set XmlHttp = CreateObject("Msxml2.XMLHTTP")
On Error GoTo checkid
Application.ScreenUpdating = False
Sheets("測試工作表").Cells.Clear
'stock_id = InputBox("股票代碼", , "8050")
'If stock_id = "" Then Exit Sub
'ttt=timer
' 將西元年轉換成民國年並格式化成中文日期
Dim queryDate As Date
queryDate = Sheets("設定主畫面").Range("G2").Value '使用查詢日期
Dim chineseYear As Integer
chineseYear = Year(queryDate) - 1911 ' 轉換成民國年
formattedDate = chineseYear & Format(queryDate, "/mm/dd") ' 中文日期格式
' 顯示中文日期
MsgBox "formattedDate: " & formattedDate
' 修改 URL
'Url = "https://www.tpex.org.tw/web/stock/aftertrading/otc_quotes_no1430/stk_wn1430_result.php?l=zh-tw&o=htm&d=113/01/10& "&se=EW&s=0,asc,0"
Urla = "https://www.tpex.org.tw/web/stock/aftertrading/otc_quotes_no1430/stk_wn1430_result.php?l=zh-tw&o=htm&d=" & formattedDate & "&se=EW&s=0,asc,0"
Url = "https://www.tpex.org.tw/web/stock/aftertrading/otc_quotes_no1430/stk_wn1430.php?l=zh-tw"
With XmlHttp
.Open "POST", Urla, False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.setRequestHeader "Referer", Url
.setRequestHeader "Cache-Control", "no-cache"
.setRequestHeader "Pragma", "no-cache"
.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
‘.send "ajax=true&input_stock_code=" & stock_id
.send
HTMLsourcecode.body[removed] = .responseText
'Debug.Print HTMLsourcecode.body.innerhtml
End With
If HTMLsourcecode.getElementsByTagName("table").Length = 0 Then
Sheets("測試工作表").Range("A1") = "查無該筆資料,請重新查詢!!"
Exit Sub
End If
With Clipboard
.SetText HTMLsourcecode.body[removed]
.PutInClipboard
End With
With Sheets("測試工作表")
.Cells(1, 1).Select
.PasteSpecial Format:="HTML"
End With
Application.ScreenUpdating = True
Set Clipboard = Nothing
Set HTMLsourcecode = Nothing
Set XmlHttp = Nothing
checkid:
If Err.Number <> 0 Then
Debug.Print Err.Description
End If
End Sub
個人積分：3127分
文章編號：88967109
個人積分：3127分
文章編號：88967132
