返回列表 上一主題 發帖

[發問] 一個用VBA從網頁取得想要資料的寫法~

回復 30# bioleon69
  1. ''CreateObject("InternetExplorer.Application") 需等候網頁下載完畢速度較慢
  2. '執行迴圈讓它跑1500次,嘿速度會慢許多
  3. Option Explicit
  4. Sub 測試()
  5.     Dim oXmlhttp As Object, oHtmldoc As Object, surl, E As Object
  6.     Set oXmlhttp = CreateObject("msxml2.xmlhttp")
  7.     Set oHtmldoc = CreateObject("htmlfile")
  8.     surl = "http://norway.twsthr.info/StockHolders.aspx?stock=2330"
  9.     With oXmlhttp
  10.         .Open "Get", surl, False
  11.         .Send
  12.         oHtmldoc.write .responseText
  13.     End With
  14.     With oHtmldoc
  15.         Set E = .all.tags("TABLE")(9)
  16.     End With
  17.     Application.ScreenUpdating = False
  18.     Ex_副程式 E
  19.     Application.ScreenUpdating = True
  20. End Sub
  21. Private Sub Ex_副程式(A As Object)
  22.     Dim i As Integer, R As Integer, C As Integer
  23.     With ActiveSheet    '可指定工作表
  24.         .UsedRange.Clear
  25.         For R = 0 To 2 * 5    '讀取5筆資料 ' 雙數的A.Rows為空白資料
  26.             If R <= 1 Or R > 2 And R Mod 2 = 1 Then '剔除 雙數的A.Rows
  27.                 i = i + 1
  28.                 For C = 2 To A.Rows(R).Cells.Length - 1
  29.                     .Cells(i, C - 1) = A.Rows(R).Cells(C).innertext
  30.                 Next
  31.             End If
  32.         Next
  33.         With .UsedRange  ' CELL 為整工作表的儲存格 範圍大(費時)
  34.            ' .UsedRange 工作表有使用到的的儲存格 範圍小(省時)
  35.             .EntireRow.AutoFit
  36.             .EntireColumn.AutoFit
  37.         End With
  38.     End With
  39. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

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

回復 31# GBKEE


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

THX G大!

TOP

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

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


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



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

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

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

求指導!感謝

TOP

回復 33# bioleon69

可改用會入外部資料 .QueryTables
  1. Option Explicit
  2. Sub Ex()
  3.     With ActiveSheet.QueryTables.Add(Connection:="URL;http://mops.twse.com.tw/nas/t21/sii/t21sc03_106_3_0.html", Destination:=Range("A1"))
  4.         .WebSelectionType = xlSpecifiedTables
  5.         .WebFormatting = xlWebFormattingNone
  6.         .WebTables = "4"
  7.         .RefreshStyle = xlOverwriteCells
  8.         .WebPreFormattedTextToColumns = True
  9.         .WebConsecutiveDelimitersAsOne = True
  10.         .WebSingleBlockTextImport = False
  11.         .WebDisableDateRecognition = False
  12.         .WebDisableRedirections = False
  13.         .Refresh BackgroundQuery:=False
  14.     End With
  15. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 33# bioleon69
  1. Option Explicit
  2. Sub 測試()
  3.     Dim oXmlhttp As Object, oHtmldoc As Object, surl, E As Object
  4.     Set oXmlhttp = CreateObject("msxml2.xmlhttp")
  5.     Set oHtmldoc = CreateObject("htmlfile")
  6.     surl = "http://mops.twse.com.tw/nas/t21/sii/t21sc03_106_3_0.html"
  7.     With oXmlhttp
  8.         .Open "Get", surl, False
  9.         .Send
  10.         'oHtmldoc.write .responseText
  11.         oHtmldoc.write BinToStr(.responseBody, "BIG5") '網頁編碼 "中文"
  12.     End With
  13.     With oHtmldoc
  14.         Set E = .all.tags("TABLE")(3)
  15.     End With
  16.     Application.ScreenUpdating = False
  17.     Ex_副程式 E
  18.     Application.ScreenUpdating = True
  19. End Sub
  20. Private Sub Ex_副程式(A As Object)
  21.     Dim i As Integer, R As Integer, C As Integer
  22.     With ActiveSheet    '可指定工作表
  23.         .UsedRange.Clear
  24.         For R = 0 To A.Rows.Length - 1
  25.                 For C = 0 To A.Rows(R).Cells.Length - 1
  26.                     .Cells(R + 1, C + 1) = A.Rows(R).Cells(C).innertext
  27.                 Next
  28.         Next
  29.         With .UsedRange  ' CELL 為整工作表的儲存格 範圍大(費時)
  30.            ' .UsedRange 工作表有使用到的的儲存格 範圍小(省時)
  31.             .EntireRow.AutoFit
  32.             .EntireColumn.AutoFit
  33.         End With
  34.     End With
  35. End Sub
  36. Function BinToStr(arrBin, strChrs) As String
  37.     With CreateObject("ADODB.Stream")  '二進位文檔,傳送,儲存
  38.         .Type = 2
  39.         .Open
  40.         .Writetext arrBin
  41.         .Position = 0
  42.         .Charset = strChrs   '指定編碼
  43.         BinToStr = .ReadText
  44.         .Close
  45.     End With
  46. End Function
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

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

回復 35# GBKEE


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

感謝GBK大!

TOP

回復 35# GBKEE

午安 G大

你的這個轉碼系統

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

例如(以下)
  1. Sub 下載CSV()
  2. Set book1 = ActiveSheet
  3. Set bookshow = book1.QueryTables _
  4.     .Add(Connection:="TEXT;https://smart.tdcc.com.tw/opendata/getOD.ashx?id=2-8", _
  5.         Destination:=book1.Range("a1"))
  6. With bookshow

  7.     .TextFileParseType = xlDelimited
  8.   .TextFileCommaDelimiter = True
  9.     .Refresh
  10. End With

  11. End Sub
複製代碼
VBA 從0開始
先從學會看的懂開始
先從會有基本修改能力開始
一步一步學習中

TOP

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

回復 37# bioleon69


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

我一個一個測試,應該是第12個表格沒有錯
為什麼會下載不了呢??奇怪
  1. Sub TEST()
  2.     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"))
  3.         .Name = "上市持股轉讓"
  4.         .WebFormatting = xlWebFormattingNone
  5.         .WebTables = "12"
  6.         .RefreshStyle = xlOverwriteCells
  7.         .WebPreFormattedTextToColumns = True
  8.         .WebConsecutiveDelimitersAsOne = True
  9.         .WebDisableDateRecognition = False
  10.         .Refresh BackgroundQuery:=False
  11.     End With
  12. End Sub
複製代碼
VBA 從0開始
先從學會看的懂開始
先從會有基本修改能力開始
一步一步學習中

TOP

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 39# GBKEE


要用ie的方法嗎??
煩請大大幫忙看一下程式碼哪邊有問題,我寫的那兩行都不能按下去
  1. Sub test()
  2. Dim ie, ab, cc
  3.     Set ie = CreateObject("InternetExplorer.Application")
  4.     With ie
  5.          .Visible = True
  6.         .navigate "http://mops.twse.com.tw/mops/web/t56sb21_q3"
  7.         Do Until .ReadyState = 4
  8.             DoEvents
  9.         Loop
  10.         Set cc = .document
  11.         Set ab = .document.forms("form1")
  12.         ab.typek.Value = "otc"
  13.         ab.Year.Value = "105"
  14.         ab.smonth.Value = "03"
  15.         ab.emonth.Value = "04"
  16.         'cc.getelementbyid("search_bar1").Click
  17.        ' ab.submit
  18.         End With
  19. End Sub
複製代碼
VBA 從0開始
先從學會看的懂開始
先從會有基本修改能力開始
一步一步學習中

TOP

        靜思自在 : 生氣,就是拿別人的過錯來懲罰自己。
返回列表 上一主題