[發問] 請問有人知道上櫃個股年成交資訊如何匯入Excel

shuasa

請問有人知道上櫃個股年成交資訊如何匯入Excel
http://www.tpex.org.tw/web/stock/statistics/monthly/st42.php?l=zh-tw
例如我要查詢4947,按"列印/匯出HTML" 產生的網頁
http://www.tpex.org.tw/web/stock/statistics/monthly/print_st42.php?l=zh-tw
看不出實際的網址,附檔"紫色標籤的工作表"未完成部份......

GBKEE

回復 1# shuasa
試試看

1. Option Explicit
   
2. Private Sub Worksheet_Change(ByVal Target As Range)
   
3.     Application.EnableEvents = False
   
4.     If Target.Address = "$B$1" Then 'B1變更就執行 (更新資料)
   
5.         Ex_上櫃個股成交資 Target
   
6.     End If
   
7.     Application.EnableEvents = True
   
8. End Sub
   
9. Sub Ex_上櫃個股成交資(nCode)
   
10.     Dim E As Object, R As Integer, C As Integer, St As String, Rng As Range
    
11.     With CreateObject("InternetExplorer.Application")
    
12.         .Visible = True
    
13.         .Top = 1: .Left = 1: .Width = 1: .Height = 1
    
14.         .Navigate "http://www.tpex.org.tw/web/stock/statistics/monthly/st42.php?l=zh-tw"
    
15.         Do While .Busy Or .readyState <> 4: DoEvents: Loop
    
16.         With .Document.all("input_stock_code")
    
17.             .Value = nCode
    
18.             .Focus
    
19.             Application.SendKeys "~"    '按下Eenter鍵
    
20.         End With
    
21.         Do While .Busy Or .readyState <> 4: DoEvents: Loop
    
22.         Do While .Document.all.tags("table") Is Nothing: DoEvents: Loop
    
23.         Do While .Document.all.tags("table").Length < 4:
    
24.             Set E = .Document.all.tags("table")(0)
    
25.             If InStr(E.innertext, "查無該筆資料,請重新查詢!!") Then St = nCode & vbLf & E.innertext: GoTo bby
    
26.             If InStr(E.innertext, "您輸入的股票代碼有誤，請檢查!!") Then St = nCode & vbLf & "的股票代碼有誤，請檢查": GoTo bby
    
27.             DoEvents
    
28.         Loop
    
29.         Set E = .Document.all.tags("table")(2)
    
30.         Set Rng = Range("b3")
    
31.         With Rng
    
32.             .CurrentRegion.Clear
    
33.             For R = 0 To E.Rows.Length - 1
    
34.                 For C = 0 To E.Rows(R).Cells.Length - 1
    
35.                     .Cells(R + 1, C + 1) = E.Rows(R).Cells(C).innertext
    
36.                 Next
    
37.             Next
    
38.         End With
    
39.         Rng = .Document.all.tags("table")(0).Rows(0).Cells(1).innertext
    
40. bby:
    
41.         .Quit        '關閉網頁
    
42.     End With
    
43.     If St <> "" Then MsgBox vbTab & St: Range("b3").CurrentRegion.Clear
    
44. End Sub

複製代碼

shuasa

回復 2# GBKEE


    感謝GBKEE大指導,問題解決了,謝謝您!