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

Option Explicit
Sub Ex()
Dim DATE_REQ As Date, yyyymm As String, yyyymmdd As String, yyymmdd As String
Dim URL As String, A As Object, E As String, i As Integer, ii As Integer, Sh As Worksheet, t As Date
On Error GoTo IE_ER
DATE_REQ = Date
Do
If Weekday(DATE_REQ, vbMonday) > 5 Then DATE_REQ = DATE_REQ - 1 '取得營業日
Loop Until Weekday(DATE_REQ, vbMonday) <= 5
DATE_REQ = CDate(InputBox("請輸入交易日期, 格式 2011/9/6", , DATE_REQ))
yyyymm = Year(DATE_REQ) & Format(Month(DATE_REQ), "00")
yyyymmdd = Year(DATE_REQ) & Format(Month(DATE_REQ), "00") & Format(Day(DATE_REQ), "00")
yyymmdd = Year(DATE_REQ) - 1911 & "/" & Format(Month(DATE_REQ), "00") & "/" & Format(Day(DATE_REQ), "00")
URL = "http://www.twse.com.tw/ch/trading/exchange/MI_INDEX/genpage/Report" & yyyymm & "/A112" & yyyymmdd & "ALLBUT0999_1.php?select2=ALLBUT0999&chk_date=" & yyymmdd
Set Sh = ActiveSheet
Sh.Cells.Clear
Application.StatusBar = " 等候網頁...."
t = Time
With CreateObject("InternetExplorer.Application")
.Navigate URL
' .Visible = True
Do While .Busy Or .ReadyState <> 4
DoEvents
Loop
If .document.Title = "HTTP 404 找不到" Then 'IE8 瀏覽器
.Quit
GoTo IE_ER
End If
Do
Set A = .document.getElementsByTAGName("TABLE")(9)
Loop While A Is Nothing
With Sh
For i = 0 To A.Rows.Length - 1
For ii = 0 To A.Rows(i).Cells.Length - 1
'.Cells(i + 1, "a").Select
E = Trim(A.Rows(i).Cells(ii).innerText) '網頁的字串
.Cells(i + 1, ii + 1) = E ' A.Rows(i).Cells(II).innerText
'網頁的字串轉存到儲存格,"0050"視為數字自動去除"00"
If ii = 0 And Cells(i + 1, ii + 1).Text <> E Then
.Cells(i + 1, ii + 1).NumberFormatLocal = "@" '儲存格格式改為文字
.Cells(i + 1, ii + 1) = E '重新給上網頁的字串
End If
Application.StatusBar = Application.Text(Time - t, "[s]") & "秒資料下載...." & .Cells(i + 1, ii + 1)
Next
Next
End With
.Quit
End With
Application.StatusBar = Application.Text(Time - t, "[s]") & "秒資料下載完畢"
Exit Sub
IE_ER: '日期錯誤
MsgBox IIf(Err = 13, "日期取消輸入", DATE_REQ & " 日期有誤")
Application.StatusBar = False
End Sub

複製代碼