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

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Address = "$B$1" Then 'B1變更就執行 (更新資料)
Ex_上櫃個股成交資 Target
End If
Application.EnableEvents = True
End Sub
Sub Ex_上櫃個股成交資(nCode)
Dim E As Object, R As Integer, C As Integer, St As String, Rng As Range
With CreateObject("InternetExplorer.Application")
.Visible = True
.Top = 1: .Left = 1: .Width = 1: .Height = 1
.Navigate "http://www.tpex.org.tw/web/stock/statistics/monthly/st42.php?l=zh-tw"
Do While .Busy Or .readyState <> 4: DoEvents: Loop
With .Document.all("input_stock_code")
.Value = nCode
.Focus
Application.SendKeys "~" '按下Eenter鍵
End With
Do While .Busy Or .readyState <> 4: DoEvents: Loop
Do While .Document.all.tags("table") Is Nothing: DoEvents: Loop
Do While .Document.all.tags("table").Length < 4:
Set E = .Document.all.tags("table")(0)
If InStr(E.innertext, "查無該筆資料,請重新查詢!!") Then St = nCode & vbLf & E.innertext: GoTo bby
If InStr(E.innertext, "您輸入的股票代碼有誤，請檢查!!") Then St = nCode & vbLf & "的股票代碼有誤，請檢查": GoTo bby
DoEvents
Loop
Set E = .Document.all.tags("table")(2)
Set Rng = Range("b3")
With Rng
.CurrentRegion.Clear
For R = 0 To E.Rows.Length - 1
For C = 0 To E.Rows(R).Cells.Length - 1
.Cells(R + 1, C + 1) = E.Rows(R).Cells(C).innertext
Next
Next
End With
Rng = .Document.all.tags("table")(0).Rows(0).Cells(1).innertext
bby:
.Quit '關閉網頁
End With
If St <> "" Then MsgBox vbTab & St: Range("b3").CurrentRegion.Clear
End Sub

複製代碼