麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 一個用VBA從網頁取得想要資料的寫法~ [打印本頁]

作者: vesperlee 時間: 2012-4-28 15:09 標題: 一個用VBA從網頁取得想要資料的寫法~

本帖最後由 GBKEE 於 2016-1-15 12:59 編輯

麻煩各位大大幫忙，謝謝，感恩~~~~。
[attach]10713[/attach]

請問~~。我想用VBA製作一個BUTTON，當我按下時能從下面網址捉到我指定的資料，並放入excel的儲存格內。該怎麼寫呢！
我只要捉以下片段的資料

                  張數          佔股本比例
董監持股       21,712       6.04%
集保庫存       364,848    101.44%
六日均量       1,834          0.51%

相關網址
http://jsjustweb.jihsun.com.tw/z/zc/zcx/zcx_6257.asp.htm
http://jsjustweb.jihsun.com.tw///z/zc/zcx/zcxD1.djjs?A=6257"

作者: vesperlee 時間: 2012-5-1 00:54

金害~！我只能捉到它的個股基本資料
為什麼捉不到我要的資料呢？
Private Sub CommandButton1_Click()
Dim webURL As String
webURL = "URL;http://jsjustweb.jihsun.com.tw/z/zc/zcx/zcx_6257.asp.htm"
With ActiveSheet.QueryTables.Add(Connection:=webURL, Destination:=Range("A1"))
      ' xlOverwriteCells 表示覆蓋欄位
      .RefreshStyle = xlOverwriteCells
            .WebTables = "1"
      .Refresh BackgroundQuery:=False
End With
End Sub

作者: chen_cook 時間: 2012-5-1 06:56

回復 2# vesperlee

好像與JAVA有關..國泰也是同樣的網頁,無法匯入 Webtable =1 正確是 2或3
其它證券有相同的資料,去抓它的來套吧!!!
其它的要求自己想吧!!

作者: white5168 時間: 2012-5-1 07:56

本帖最後由 white5168 於 2012-5-1 08:37 編輯

股票名稱及代碼是在網頁載入完成後，才用 JavaScript 動態產生的
所以 Web Query 抓不到
因為網頁資料還單純，建議用VBA開啟網頁後複製表格到excel,再選自己要的部份即可
關於股票代碼的部份請自行修改,
對於抓這樣的資料我都是用python,而且速度上也比VBA快很多
PS:寫程式時請記得加入註解,以養成良好的撰寫習慣,也讓後面的人可以方便學習

Sub Test()
Const url As String = "http://jsjustweb.jihsun.com.tw/z/zc/zck/zck_6257.asp.htm"
Cells.Clear
Set ie = CreateObject("internetexplorer.application") '使用此方式可以免除 "設定引用項目"
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
Sheets("Sheet1").Cells.Select
Range("A1").Activate
ActiveSheet.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:= _
False, NoHTMLFormatting:=True
End With
Columns("A:B").Delete
ie.Quit
MsgBox "資料複製結束"
End Sub

複製代碼

這裡比較會有問題看不懂的地方大概就是ExecWB
我附上MSDN的連結,請自行參考 http://msdn.microsoft.com/en-us/library/aa752087(v=vs.85).aspx

作者: chen_cook 時間: 2012-5-1 11:51

vesperlee
4樓大大回覆的不是你指定的網頁,請你自行調整即可達成;因非匯入所以格式會不同就是了!!

作者: c_c_lai 時間: 2012-5-1 16:42

回復 4# white5168
回復 2# vesperlee
請試試看！

Private Sub CommandButton1_Click()
' Const url As String = "http://jsjustweb.jihsun.com.tw/z/zc/zck/zck_6257.asp.htm"
Const url As String = "http://jsjustweb.jihsun.com.tw/z/zc/zcx/zcx_6257.asp.htm" ' 正確的
Cells.Clear
Set ie = CreateObject("internetexplorer.application") '使用此方式可以免除 "設定引用項目"
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
Range("A1").Activate
ActiveSheet.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:= _
False, NoHTMLFormatting:=True
End With
Columns("A:B").Delete ' 將匯入時 A、B 兩欄移除，原本 C:I 的欄位全部左靠，成為 A:I
ie.Quit
MsgBox "資料複製結束" ' 離開前顯示一小視窗提醒，按它後即結束。
End Sub

複製代碼

[attach]10772[/attach]

作者: arksu 時間: 2012-5-3 00:12

小弟提供另一個方式用xmlhttp來抓取, 然後在自己解析需要的資料
我之前是用在asp上, vba應該也是可以使用的
Function getHTTPPage(ByVal url As String)

Dim objXmlHttp As Object

objXmlHttp = Server.CreateObject("Microsoft.XMLHTTP")
objXmlHttp.Open("GET", url, False)

objXmlHttp.setRequestHeader("Content-Type", "text/html")
objXmlHttp.setRequestHeader("charset", "BIG5")

objXmlHttp.Send()

getHTTPPage = BytesToBstr(objXmlHttp.ResponseBody, "BIG5")

End Function

Function BytesToBstr(ByVal body() As Byte, ByVal CSet As String)

Dim objStream As Object

objStream = Server.CreateObject("ADODB.Stream")
objStream.Type = 1
objStream.Mode = 3
objStream.Open()
objStream.Write(body)
objStream.Position = 0
objStream.Type = 2
objStream.Charset = CSet

BytesToBstr = objStream.ReadText()

objStream.Close()

End Function

作者: c_c_lai 時間: 2012-5-3 08:06

回復 7# arksu
objXmlHttp.Open("GET", url, False) 等模組無法使用，
可能須要再入其相對 DLL，但我對 VBA 不孰，
請問該如何設定？

作者: arksu 時間: 2012-5-3 10:44

回復 8# c_c_lai

我簡單寫了個範例, 您參考一下

excel一開啟就抓取網頁內容用msgbox秀出來

[attach]10789[/attach]

作者: yuch8663 時間: 2012-5-8 01:55

還是不了解ExecWB 的運作
但是感謝分享!

作者: stillfish00 時間: 2012-5-9 10:56

哇原來除了queryTable ,
還有這些方法可以擷取網頁資料
copy & paste , XmlHttp
筆記一下 , 以後也許會用到
感謝前幾樓分享

作者: TonyTW 時間: 2012-6-7 16:40

I copied you codes but it doesn't work.
However, I'm new to this forum & do not have enough point to download your ademo.zip.
Could you please post your codes in ademo.zip for my reference ?

小弟提供另一個方式用xmlhttp來抓取, 然後在自己解析需要的資料
我之前是用在asp上, vba應該也是可以使用的 ...
arksu 發表於 2012-5-3 00:12

作者: 水元素 時間: 2013-1-21 17:01

各位大大請問一下:
小的利用4樓及6樓大大的內容做學習測試，
為何剛開始都擷取網頁內容很順利，
但測試幾次過後卻發生程式一直在下面迴圈繞

With ie
      .Visible = False 'True為開啟ie, False為不開啟ie
      .Navigate url
      Do While .ReadyState <> 4 '等待網頁開啟
      DoEvents
      Loop

獨自打開網頁也沒有問題資料一切正常，
但是我將這段改成.Visible = Ture
VBA打開的網頁卻一直無法讀取，請問這是哪出了問題??
希望各位前輩賜教!!!謝謝

作者: cji3cj6xu6 時間: 2013-4-16 17:48

我的方式比較笨，先存到一個檔案中，然後再擷取我要的部分
再利用vba轉到我要觀察的檔案裡。

作者: cji3cj6xu6 時間: 2013-6-11 17:30

請問若是我想要抓取以下資料，其中的XXXX為股票代號，請問要如何將XXXX帶入VBA
http://money.hinet.net/z/z0/z00/z00a_XXXX_2013-4-6_2013-6-11_D.djhtm

謝謝～

作者: cji3cj6xu6 時間: 2013-6-11 17:49

sorry, XXXX 是個變數，忘了寫進去～

作者: GBKEE 時間: 2013-7-28 20:28

回復 16# cji3cj6xu6
詳看檔案內的程式碼

[attach]15617[/attach]

作者: cji3cj6xu6 時間: 2013-7-29 09:40

G大，
時間那麼久了，我都忘了有問過這個問題，還有勞您費心，真不好意思。謝謝～

作者: norafang 時間: 2014-1-22 13:24

回復 white5168
回復 vesperlee
請試試看！
c_c_lai 發表於 2012-5-1 16:42

我把CC大的程式修改我想要股票名稱,但為何會跑出"必須是常數運算式"的錯誤訊息,請問我下面的寫法有錯嗎?
那不然要如何更改自己想要的股票代號呢?
請指教我這個VBA新手,謝謝

Sub a()
x = Worksheets("sheet1").Range("l1")
Const url As String = "http://jsjustweb.jihsun.com.tw/z/zc/zcl/zcl_" & x & ".asp.htm"
Cells.Clear
Set ie = CreateObject("internetexplorer.application") '使用此方式可以免除 "設定引用項目"
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
      Sheets("Sheet1").Cells.Select
      Range("A1").Activate
      ActiveSheet.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:= _
            False, NoHTMLFormatting:=True
End With
Columns("A:B").Delete
ie.Quit
MsgBox "資料複製結束"
End Sub

作者: norafang 時間: 2014-1-22 13:26

對了,順便再補問一下,類似這種網站,可以用錄製巨集的方式再下去修改嗎?
還是必須依上面大大的寫法下去修改呢?
因為靠自己寫出來,不用每次都靠別人幫忙,謝謝

作者: GBKEE 時間: 2014-1-22 14:15

回復 20# norafang
你要用IE匯入外部資料是無法用錄製,
功能表指令:資料-> 匯入外部資料,可以用錄製下來修改
19#的問題要多看看VBA說明的函數,方法,陳述式,屬性.來了解用法,可百尺竿頭,更近一步.

Option Explicit
'Const 陳述式宣告常數 , 其值如字面所示
Sub a()
Dim x, ur As String
x = "2022"
Const url As String = "http://jsjustweb.jihsun.com.tw/z/zc/zcl/zcl_AAAA.asp.htm"
MsgBox url
ur = "http://jsjustweb.jihsun.com.tw/z/zc/zcl/zcl_" & x & ".asp.htm"
MsgBox ur
End Sub

複製代碼

作者: norafang 時間: 2014-1-22 17:48

回復 21# GBKEE
G大,謝謝您的耐心指教,依您的方式,我的寫法如下:
有以下幾個問題
1.為何我已指定代號在A1,但帶出表頭,而沒有資料?
[attach]17341[/attach]
2.為何我指定放置位置於Range("AA1").Activate,跑完還是放在A2?

Sub Test()
Dim x, ur As String
x = Worksheets("sheet1").Range("a1")
Const url As String = "http://jsjustweb.jihsun.com.tw/z/zc/zcl/zcl_AAAA.asp.htm"
MsgBox url
ur = "http://jsjustweb.jihsun.com.tw/z/zc/zcl/zcl_" & x & ".asp.htm"
MsgBox ur
Cells.Clear
Set ie = CreateObject("internetexplorer.application") '使用此方式可以免除 "設定引用項目"
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
      Sheets("Sheet1").Cells.Select
      Range("AA1").Activate
      ActiveSheet.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:= _
            False, NoHTMLFormatting:=True
End With
Columns("A:B").Delete
ie.Quit
MsgBox "資料複製結束"
End Sub

煩請G大再幫我看看,謝謝

作者: GBKEE 時間: 2014-1-23 09:02

回復 22# norafang
VBA的經驗值太少了,需多修煉 21# 的程式碼是在說明 Const 陳述式

Option Explicit
Sub Test()
Dim x, ur As String, IE As Object
x = Worksheets("sheet1").Range("a1")
' Const url As String = "http://jsjustweb.jihsun.com.tw/z/zc/zcl/zcl_AAAA.asp.htm"
' MsgBox url
ur = "http://jsjustweb.jihsun.com.tw/z/zc/zcl/zcl_" & x & ".asp.htm"
' MsgBox ur
Set IE = CreateObject("internetexplorer.application") '使用此方式可以免除 "設定引用項目"
With IE
.Visible = False 'True為開啟ie, False為不開啟ie
.Navigate ur
Do While .ReadyState <> 4 '等待網頁開啟
DoEvents
Loop
.ExecWB 17, 2 'Select All
.ExecWB 12, 2 'Copy selection
With Sheets("Sheet1")
.Cells.Clear
'.Cells.Select
.Range("AA1").Activate
.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:= _
False, NoHTMLFormatting:=True
End With
End With
Columns("A:B").Delete
IE.Quit
MsgBox "資料複製結束"
End Sub

複製代碼

作者: norafang 時間: 2014-1-23 09:36

回復 23# GBKEE
G大,感謝您,已經可以跑了,雖然內容有很多我還是不太了解,但您已經給了很大的方向了,感謝唷!

作者: alantsai777 時間: 2014-12-27 15:21

請問如果網頁每10秒資料變動
如
http://mis.twse.com.tw/stock/fibest.jsp?stock=3673
隔 10 秒自動更新
[上市] 3673 F-TPK(元，交易單位)
最近
成交價漲跌價差
(百分比) 當盤
成交量累積
成交量揭示
買價揭示
買量揭示
賣價揭示
賣量開盤最高最低說明
200.00 ▲1.50(0.76%) 359 2118 199.50 11 200.00 58 199.50 200.50 198.00
能否請幫忙告知如何抓謝謝

作者: GBKEE 時間: 2014-12-28 09:23

回復 25# alantsai777
隔 10 秒自動更新 ?? 這網頁間隔 5 秒自動更新!!
程式碼複製到一般模組

Option Explicit
Dim IE As Object
Sub Ex_基本市況報導網站()
Dim A As Object, xDate As Date, EDATE As Date
Set IE = CreateObject("InternetExplorer.Application")
With IE
' .Visible = True
.Navigate "http://mis.twse.com.tw/stock/fibest.jsp?stock=3673"
Do While .Busy Or .readyState <> 4: DoEvents: Loop
End With
Ex_副程式
End Sub
Private Sub Ex_副程式()
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")(1)
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
If Time <= #1:30:00 PM# Then '收盤時間自行調整
Application.OnTime Time + #12:00:05 AM#, "Ex_副程式" '間隔5秒
Else
IE.Quit
End If
End Sub

複製代碼

作者: aaron1059 時間: 2015-9-12 13:47

請教GBKEE超級版主:
以下網頁的VBA要如何寫
https://tw.futures.finance.yahoo.com/future/options.html?opmr=optionfull&opcm=WTXO&opym=201509

作者: GBKEE 時間: 2015-9-14 06:12

本帖最後由 GBKEE 於 2015-9-14 06:14 編輯

回復 28# aaron1059
試試看
幫你找出傳回期權資料的網址不一樣.

Option Explicit
Sub Ex() 'Yahoo!奇摩股市--期權
Dim ie As Object, k As Integer, S As Integer, jj As Integer, i As Integer, AA As Object
Set ie = CreateObject("InternetExplorer.Application")
ie.Navigate "https://tw.screener.finance.yahoo.net/future/aa03?opmr=optionfull&opcm=WTFO&opym=201510&random=0.01296169775357775"
ie.Visible = True
Do While ie.Busy Or ie.ReadyState <> 4: DoEvents: Loop
Set AA = ie.Document.getelementsbytagname("table")
With Sheets(1)
.Cells.Clear
k = k + 1
For S = 0 To AA.Length - 1 '已找出網頁的table內容在 5-7 中
For i = 0 To AA(S).Rows.Length - 1 '資料的列位
For jj = 0 To AA(S).Rows(i).Cells.Length - 1 '資料的欄位
.Cells(k, jj + 1) = AA(S).Rows(i).Cells(jj).INNERTEXT
Next
k = k + 1
Next
Next
End With
ie.Quit
End Sub

複製代碼

作者: bioleon69 時間: 2017-4-30 22:19

本帖最後由 bioleon69 於 2017-4-30 22:24 編輯

GBK大請教一下
從上面爬文練習,目前可以從EXCEL叫出瀏覽器
之後要怎麼讀取網頁內容,內容寫入EXCEL
A3開始寫入
這邊真的卡住了..
以下是目前程式碼的進度

Option Explicit
Dim ie As Object
Sub 集保()
Dim keyin As String
keyin = Range("a1")
Set ie = CreateObject("InternetExplorer.Application")
With ie
.Navigate "http://norway.twsthr.info/StockHolders.aspx?stock=" & keyin & ""
.Visible = True
Do While ie.Busy Or ie.readyState <> 4: DoEvents: Loop
End With
Ex_副程式
End Sub
Private Sub Ex_副程式()
Dim A As Object
With ie
Do While .Busy Or .readyState <> 4: DoEvents: Loop
Set A = .Document.getElementsByTagName("table")
End With
With ActiveSheet '可指定工作表
.UsedRange.Clear
End With
ie.Quit
End Sub

複製代碼

懇請GBK大幫忙指點12...[attach]27121[/attach][attach]27122[/attach]

作者: bioleon69 時間: 2017-5-1 10:22

本帖最後由 bioleon69 於 2017-5-1 10:27 編輯

目前成功可執行了,也多虧版上許多資源
有幾個問題想請教

請問一下
1.為什麼我執行出來後會有空白的列?
是哪邊出了什麼狀況?

[attach]27124[/attach]

2.可以把寫入excel的資料,定義成一個東西嗎
可以用with end with來控制內容(只控制寫入的部分)
比方說字體大小,寬度高度,上色,刪除/清除,等等
不會牽動到周圍的資料

3.目前程式碼還可優化嗎?
因為想要再弄一個迴圈執行後讓它跑1500次
這程式碼會不會很吃系統資源?(怕電腦lag)

感謝
以下程式碼

Option Explicit
Dim ie As Object
Sub 測試()
Set ie = CreateObject("InternetExplorer.Application")
With ie
.Navigate "http://norway.twsthr.info/StockHolders.aspx?stock=2330"
.Visible = True
Do While ie.Busy Or ie.readyState <> 4: DoEvents: Loop
End With
UsedRange.Clear
Ex_副程式
End Sub
Private Sub Ex_副程式()
Dim A, i, ii
With ie
Do While .Busy Or .readyState <> 4: DoEvents: Loop
Set A = .Document.getElementsByTagName("table")(9)
End With
With ActiveSheet '可指定工作表
For i = 0 To A.Rows.Length - 296
For ii = 3 To A.Rows(i).Cells.Length - 1
.Cells(i + 1, ii - 2) = A.Rows(i).Cells(ii).innertext
Next
Next
With Cells
.EntireRow.AutoFit
.EntireColumn.AutoFit
End With
End With
ie.Quit
End Sub

複製代碼

另外附上檔案
[attach]27123[/attach]

作者: GBKEE 時間: 2017-5-1 15:56

回復 30# bioleon69

''CreateObject("InternetExplorer.Application") 需等候網頁下載完畢速度較慢
'執行迴圈讓它跑1500次,嘿速度會慢許多
Option Explicit
Sub 測試()
Dim oXmlhttp As Object, oHtmldoc As Object, surl, E As Object
Set oXmlhttp = CreateObject("msxml2.xmlhttp")
Set oHtmldoc = CreateObject("htmlfile")
surl = "http://norway.twsthr.info/StockHolders.aspx?stock=2330"
With oXmlhttp
.Open "Get", surl, False
.Send
oHtmldoc.write .responseText
End With
With oHtmldoc
Set E = .all.tags("TABLE")(9)
End With
Application.ScreenUpdating = False
Ex_副程式 E
Application.ScreenUpdating = True
End Sub
Private Sub Ex_副程式(A As Object)
Dim i As Integer, R As Integer, C As Integer
With ActiveSheet '可指定工作表
.UsedRange.Clear
For R = 0 To 2 * 5 '讀取5筆資料 ' 雙數的A.Rows為空白資料
If R <= 1 Or R > 2 And R Mod 2 = 1 Then '剔除雙數的A.Rows
i = i + 1
For C = 2 To A.Rows(R).Cells.Length - 1
.Cells(i, C - 1) = A.Rows(R).Cells(C).innertext
Next
End If
Next
With .UsedRange ' CELL 為整工作表的儲存格範圍大(費時)
' .UsedRange 工作表有使用到的的儲存格範圍小(省時)
.EntireRow.AutoFit
.EntireColumn.AutoFit
End With
End With
End Sub

複製代碼

作者: bioleon69 時間: 2017-5-1 21:38

本帖最後由 bioleon69 於 2017-5-1 21:40 編輯

回復 31# GBKEE

了解
對這兩個物件還很陌生
CreateObject("msxml2.xmlhttp")
CreateObject("htmlfile")
目前也幾乎都是抄寫G大留下的程式碼修改學習
趕緊來學習看看

THX G大!

作者: bioleon69 時間: 2017-5-3 06:34

本帖最後由 bioleon69 於 2017-5-3 06:35 編輯

兩個疑問
#亂碼
#全部表格的指定方法

http://mops.twse.com.tw/nas/t21/sii/t21sc03_106_3_0.html
如果是這個網頁
會變這樣

[attach]27139[/attach]

如果是要抓這網頁的全部表格內容
非單一指定表格

應該怎麼修改?
With oHtmldoc
Set E = .all.tags("TABLE")(9)
End With

關鍵應該是這一行?後面打(0)會出現錯誤

求指導!感謝

作者: GBKEE 時間: 2017-5-4 08:28

回復 33# bioleon69

可改用會入外部資料 .QueryTables

Option Explicit
Sub Ex()
With ActiveSheet.QueryTables.Add(Connection:="URL;http://mops.twse.com.tw/nas/t21/sii/t21sc03_106_3_0.html", Destination:=Range("A1"))
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "4"
.RefreshStyle = xlOverwriteCells
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
End Sub

複製代碼

作者: GBKEE 時間: 2017-5-8 05:53

回復 33# bioleon69

Option Explicit
Sub 測試()
Dim oXmlhttp As Object, oHtmldoc As Object, surl, E As Object
Set oXmlhttp = CreateObject("msxml2.xmlhttp")
Set oHtmldoc = CreateObject("htmlfile")
surl = "http://mops.twse.com.tw/nas/t21/sii/t21sc03_106_3_0.html"
With oXmlhttp
.Open "Get", surl, False
.Send
'oHtmldoc.write .responseText
oHtmldoc.write BinToStr(.responseBody, "BIG5") '網頁編碼 "中文"
End With
With oHtmldoc
Set E = .all.tags("TABLE")(3)
End With
Application.ScreenUpdating = False
Ex_副程式 E
Application.ScreenUpdating = True
End Sub
Private Sub Ex_副程式(A As Object)
Dim i As Integer, R As Integer, C As Integer
With ActiveSheet '可指定工作表
.UsedRange.Clear
For R = 0 To A.Rows.Length - 1
For C = 0 To A.Rows(R).Cells.Length - 1
.Cells(R + 1, C + 1) = A.Rows(R).Cells(C).innertext
Next
Next
With .UsedRange ' CELL 為整工作表的儲存格範圍大(費時)
' .UsedRange 工作表有使用到的的儲存格範圍小(省時)
.EntireRow.AutoFit
.EntireColumn.AutoFit
End With
End With
End Sub
Function BinToStr(arrBin, strChrs) As String
With CreateObject("ADODB.Stream") '二進位文檔,傳送,儲存
.Type = 2
.Open
.Writetext arrBin
.Position = 0
.Charset = strChrs '指定編碼
BinToStr = .ReadText
.Close
End With
End Function

複製代碼

作者: bioleon69 時間: 2017-5-8 06:04

本帖最後由 bioleon69 於 2017-5-8 06:05 編輯

回復 35# GBKEE

漂亮,目前在學著用XML啦
那個轉碼的漂亮,雖然不是很懂寫法
小弟只能先抄下來死背套用
論壇終於好了XDD

感謝GBK大!

作者: bioleon69 時間: 2017-5-13 12:11

回復 35# GBKEE

午安 G大

你的這個轉碼系統

如果是在QT的話,該怎麼呼叫?
謝謝您^^辛苦了

例如(以下)

Sub 下載CSV()
Set book1 = ActiveSheet
Set bookshow = book1.QueryTables _
.Add(Connection:="TEXT;https://smart.tdcc.com.tw/opendata/getOD.ashx?id=2-8", _
Destination:=book1.Range("a1"))
With bookshow
.TextFileParseType = xlDelimited
.TextFileCommaDelimiter = True
.Refresh
End With
End Sub

複製代碼

作者: bioleon69 時間: 2017-5-13 15:06

本帖最後由 bioleon69 於 2017-5-13 15:16 編輯

回復 37# bioleon69

GGGG大..還有一個問題..
(拍謝,讓G大最近很忙哈哈!)

我一個一個測試,應該是第12個表格沒有錯
為什麼會下載不了呢??奇怪

Sub TEST()
With ActiveSheet.QueryTables.Add(Connection:="URL;http://mops.twse.com.tw/mops/web/t56sb21_q3?encodeURIComponent=1&run=Y&step=1&TYPEK=sii&year=105&smonth=01&emonth=02&sstep=1&firstin=true", Destination:=Range("A1"))
.Name = "上市持股轉讓"
.WebFormatting = xlWebFormattingNone
.WebTables = "12"
.RefreshStyle = xlOverwriteCells
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebDisableDateRecognition = False
.Refresh BackgroundQuery:=False
End With
End Sub

複製代碼

作者: GBKEE 時間: 2017-5-14 15:52

回復 38# bioleon69

這裡看看無法用外部資料匯入的網站能用VBA讀取資料嗎？

作者: bioleon69 時間: 2017-5-14 22:25

回復 39# GBKEE

要用ie的方法嗎??
煩請大大幫忙看一下程式碼哪邊有問題,我寫的那兩行都不能按下去

Sub test()
Dim ie, ab, cc
Set ie = CreateObject("InternetExplorer.Application")
With ie
.Visible = True
.navigate "http://mops.twse.com.tw/mops/web/t56sb21_q3"
Do Until .ReadyState = 4
DoEvents
Loop
Set cc = .document
Set ab = .document.forms("form1")
ab.typek.Value = "otc"
ab.Year.Value = "105"
ab.smonth.Value = "03"
ab.emonth.Value = "04"
'cc.getelementbyid("search_bar1").Click
' ab.submit
End With
End Sub

複製代碼

作者: GBKEE 時間: 2017-5-15 08:46

回復 40# bioleon69

Option Explicit
Sub test()
Dim Ie As Object, e As Object, R As Integer, C As Integer
'Set Ie = CreateObject("InternetExplorer.Application")
With CreateObject("InternetExplorer.Application")
'.Visible = True
.Navigate "http://mops.twse.com.tw/mops/web/t56sb21_q3"
Do While .Busy Or .readyState <> 4: DoEvents: Loop
'**************************************
With .Document.forms("form1")
.typek.Value = "otc"
.Year.Value = "105"
.smonth.Value = "03"
.emonth.Value = "04"
End With
''******************************************
For Each e In .Document.ALL.TAGS("input")
If e.Type = "button" And e.Value = " 查詢 " Then e.Click
Next
'*****************************************
Do
DoEvents
Set e = .Document.ALL("TABLE01").ALL.TAGS("TABLE")(0)
Loop Until Not e Is Nothing
資料寫入 e
.Quit
End With
End Sub
Sub Ex()
With CreateObject("InternetExplorer.Application")
.Navigate "http://mops.twse.com.tw/mops/web/t56sb21_q3?encodeURIComponent=1&run=Y&step=1&TYPEK=sii&year=105&smonth=01&emonth=02&sstep=1&firstin=true"
Do While .Busy Or .readyState <> 4: DoEvents: Loop
資料寫入 .Document.ALL("TABLE01").ALL.TAGS("TABLE")(0)
.Quit
End With
End Sub
Private Sub 資料寫入(ByVal xTable As Object)
Dim R As Integer, C As Integer
With ActiveSheet
.UsedRange.Clear
Application.ScreenUpdating = False
For R = 0 To xTable.Rows.Length - 1
For C = 0 To xTable.Rows(R).Cells.Length - 1
.Cells(R + 1, C + 1) = xTable.Rows(R).Cells(C).INNERTEXT
Next
Next
.UsedRange.WrapText = False
Application.ScreenUpdating = True
End With
End Sub

複製代碼

作者: bioleon69 時間: 2017-5-15 17:04

本帖最後由 bioleon69 於 2017-5-15 17:16 編輯

回復 41# GBKEE
G大,第一段程式的FOR EACH那邊確實可以模擬點擊
小弟先收下了!!
---------------------
第一段(test)的應該是您回應我如何模擬點擊吧
以這個例子而言,似乎沒辦法從主搜尋網址
http://mops.twse.com.tw/mops/web/t56sb21_q3
模擬點擊後,直接在抓下面的table資料
而必須從
http://mops.twse.com.tw/mops/web/t56sb21_q3?encodeURIComponent=1&run=Y&step=1&TYPEK=sii&year=105&smonth=01&emonth=02&sstep=1&firstin=true
去抓資料
之後的第二段(ex)跟第三段(資料寫入)才是一個網抓對吧?(小弟理解)

---------------------

Private Sub 資料寫入(ByVal xTable As Object)
這個byval不是很懂,為何不直接dim到sub裡面?

以下是小弟自己最大理解能力的寫法,也是沒辦法成功寫入
還請G大幫忙指正一下錯誤,謝謝您^^"

Sub test()
'*****************************************
Dim Ie
Set Ie = CreateObject("InternetExplorer.Application")
With Ie
'Visible = True
.Navigate "http://mops.twse.com.tw/mops/web/t56sb21_q3?encodeURIComponent=1&run=Y&step=1&TYPEK=sii&year=105&smonth=01&emonth=02&sstep=1&firstin=true"
Do Until .readyState = 4
DoEvents
Loop
'*****************************************
Set cc = .Document.body
Set tb = cc.all.tags("table")(0).Rows '定義表格為陣列
'Debug.Print tb.innertext '除錯用
'*****************************************
With ActiveSheet
.UsedRange.Clear
For i = 0 To tb.Length - 1
For j = 0 To tb(i).Cells.Length - 1
.Cells(i + 1, j + 1) = tb(i).Cells(j).innertext '逐一寫入
Next
Next
End With
End With
Ie.Quit
Set Ie = Nothing
End Sub

複製代碼

作者: GBKEE 時間: 2017-5-16 05:37

回復 42# bioleon69

Set tb = cc.all.tags("table")(12).Rows

複製代碼

對於 byval不是很懂!可參考VBA的說明.
Sub 陳述式
有效率地傳遞引數

作者: bioleon69 時間: 2017-5-16 23:02

回復 43# GBKEE

ok了!謝謝g大愛您~^^

byval目前就先不考慮了= =||

作者: ABK 時間: 2017-6-26 16:21

請教一下! 我想下載http://isin.twse.com.tw/isin/C_public.jsp?strMode=2 上面的資料，使用white5168大的 VBA碼，出現"Class WorksheetSpecial方法失敗"。請問是哪裡有問題?

Sub Test()
Const url As String = "http://isin.twse.com.tw/isin/C_public.jsp?strMode=2"
Cells.Clear
Set ie = CreateObject("internetexplorer.application") '使用此方式可以免除 "設定引用項目"
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
      Sheets("工作表1").Cells.Select
      Range("A1").Activate
      ActiveSheet.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:= _
            False, NoHTMLFormatting:=True
End With
Columns("A:B").Delete
ie.Quit
MsgBox "資料複製結束"
End Sub

[attach]27380[/attach]

作者: ABK 時間: 2017-6-26 23:16

解決了!

討論區內找到一篇相關的貼文
[上市個股日成交資訊下載改版建議]
http://forum.twbts.com/viewthrea ... amp;from=indexheats

由該篇 joey0415大提供的 VBA碼小改一下就OK了!

Sub 股票代碼更新()

Cells.Clear
surl = "http://isin.twse.com.tw/isin/C_public.jsp?strMode=2"
Range("A1").Select
With ActiveSheet.QueryTables.Add(Connection:="URL;" & surl, Destination:=Range("$A$1"))
.Refresh BackgroundQuery:=False
End With

End Sub

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)