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

Option Explicit
Sub Ex_營益分析查詢彙總表() '公開資訊觀測站
Dim i As Variant, E As Object, Op As String, Sh As Worksheet, R As Integer, C As Integer
Application.StatusBar = "'** 等候網頁 ....**"
With CreateObject("InternetExplorer.Application")
' .Visible = True
.Navigate "http://mops.twse.com.tw/mops/web/t163sb06"
Do While .Busy Or .ReadyState <> 4: DoEvents: Loop
'[上市別] *****
With .document.ALL("TYPEK")(1)
For i = 0 To .ALL.Length - 1
Op = Op & vbLf & i + 1 & .ALL(i).INNERTEXT
Next
DoEvents ' ** 回到 Excel
Do
Application.ActiveWindow.Activate
i = Application.InputBox(Op, "營益分析查詢彙總表 [上市別]", 1, Type:=1)
If i = 0 Then GoTo Exit_Sub
Loop Until i <= .ALL.Length And i >= 1
.selectedindex = i - 1
End With
'[年度] *****
Do
i = Application.InputBox(Format(Date, "ee"), "營益分析查詢彙總表 [年度]", Format(Date, "ee") - 1, Type:=1)
If i = 0 Then GoTo Exit_Sub
Loop Until i <= Format(Date, "ee")
.document.ALL("year").Value = i
'[季別] *****
Do
i = Application.InputBox(1, "營益分析查詢彙總表 [季別]", DatePart("q", Date), Type:=1)
If i = 0 Then GoTo Exit_Sub
Loop Until i <= 4 And i >= 1
.document.ALL("season").selectedindex = i
'** 網頁按下 [搜尋]
For Each E In .document.ALL.tags("INPUT")
If E.Value = " 搜尋 " Then
E.Click
Exit For
End If
Next
'** 等候網頁載入資料
Application.StatusBar = "'** 等候網頁載入資料**"
Do
Set E = .document.BODY.ALL.tags("table")(11).Rows
If InStr(.document.BODY.INNERTEXT, "查詢無資料") Then
MsgBox "查詢無資料"
Application.StatusBar = "** 網頁查詢無資料**"
GoTo Exit_Sub:
End If
DoEvents:
Loop Until E.Length > 11
'** 下載資料
Set Sh = Sheets(2) '指定工作表
Application.ScreenUpdating = False
Application.StatusBar = "'** 載入資料中 **"
Set E = .document.BODY.ALL.tags("table")(11).Rows
Sh.UsedRange.Clear
For R = 0 To E.Length - 1
For C = 0 To E(R).Cells.Length - 1
If R > 1 And E(R).Cells(0).INNERTEXT = "公司代號" Then Exit For
Sh.Cells(R + 1, C + 1) = E(R).Cells(C).INNERTEXT
Next
Next
Sh.UsedRange.SpecialCells(xlCellTypeBlanks).Delete
Sh.Activate
Sh.[A1].Select
Application.ScreenUpdating = True
Application.StatusBar = .document.BODY.ALL.tags("table")(12).INNERTEXT
Exit_Sub:
.Quit '關閉網頁
End With
End Sub

複製代碼