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

Dim 網頁 As Object
Sub 半自動()
Dim i As Integer, K As Integer, ii, J
Dim path As String
path = "C:\Stock\"
'程式第一次執行: 打開網頁,在網頁中手動選擇資料後 , 按[總行]or[選定分行] ; 有資料的,執行第2次下載後會自動關閉網頁
'程式第二次執行: 讀取網頁資料到 Excel中. (有出現table資料表的,再按一次執行程式則會下載檔案至目標)
年度 = "103"
季期 = "3"
代號 = "2880"
On Error GoTo RE網頁
1:
If 網頁 Is Nothing Then
Set 網頁 = CreateObject("InternetExplorer.Application")
With 網頁
.Visible = True
.navigate "http://mops.twse.com.tw/mops/web/t164sb04?encodeURIComponent=1&step=1&firstin=ture&off=1&keyword4=&code1=&TYPEK2=&checkbtn=&queryName=co_id&TYPEK=all&isnew=false&co_id=" & 代號 & "&year=" & 年度 & "&season=" & 季期
.Height = 500
.Width = 1050
End With
Exit Sub
End If
If 網頁.Visible = False Then
網頁.Value = True
Exit Sub
End If
'**********讀取網頁資料 *******************
Set A = 網頁.document.getElementsByTagName("table")
With Workbooks.Add
On Error Resume Next
'************************
' For ii = 0 To A.Length - 1 '不知道table範圍在何處: 從0開始
'************************
For ii = 11 To A.Length - 1
For i = 0 To A(ii).Rows.Length - 1
K = K + 1
For J = 0 To 8
Cells(K, J + 1) = A(ii).Rows(i).Cells(J).innerText
Next
Next
Next
'
If Dir(path & 代號 & ".xls") <> "" Then Kill (path & 代號 & ".xls")
ActiveWorkbook.SaveAs Filename:=path & 代號 & ".xls"
ActiveWindow.Close
End With
Set A = Nothing
網頁.Quit '打開的網頁,再次執行後會自動下載有table的資料,完成下載後,自動關閉已下載完成的IE網頁
Exit Sub
RE網頁:
Set 網頁 = Nothing
Resume 1
End Sub

複製代碼

Dim 網頁 As Object, Ar1 As String, xPath As String
Sub EX_自動()
Dim i As Integer, k As Integer, AR() As String, j As Integer
xPath = "d:\" '存檔位置,自己修正一下
Ar1 = ""
年度 = "103"
季期 = "3"
代號 = "2880"
Set 網頁 = CreateObject("InternetExplorer.Application")
With 網頁
'.Visible = True
.Navigate "http://mops.twse.com.tw/mops/web/t164sb04?'encodeURIComponent=1&step=1&firstin=ture&off=1&keyword4=&code1=&TYPEK2=&checkbtn=&queryName=co_id&TYPEK=all&isnew=false&co_id=" & 代號 & "&year=" & 年度 & "&season=" & 季期
Do While .Busy Or .readyState <> 4: DoEvents: Loop
If InStr(.Document.body.innertexT, "查無公司資料") Then
MsgBox 代號 & " : 查無公司資料!"
.Quit
End
End If
'**************** 讀取金控股子公司名稱
With .Document.getElementsByTagName("TABLE")(11)
ReDim AR(1 To .Rows.Length - 1)
For i = 1 To .Rows.Length - 1
For j = 0 To .Rows(i).Cells.Length - 2
AR(i) = AR(i) & IIf(AR(i) <> "", "-", "") & .Rows(i).Cells(j).innertexT
Next
Next
End With
'*****************************
Set A = .Document.getElementsByTagName("INPUT")
i = 1
For E = 0 To A.Length - 1
If A(E).Value = "詳細資料" And A(E).Type = "button" Then
A(E).Click '有"詳細資料" 金控股子公司的按鈕
Do While 網頁.Busy Or 網頁.readyState <> 4: DoEvents: Loop
If InStr(.Document.body.innertexT, "查無") = 0 Then '金控股子公司有資料
IE_Table AR(i) '參數傳遞:金控股子公司的名稱
End If
For Each Img In .Document.getElementsByTagName("img")
'http://mops.twse.com.tw/mops/web/images/bu_05.gif 回上頁的圖片
If Img.href = "http://mops.twse.com.tw/mops/web/images/bu_05.gif" Then
Img.Click
Do While 網頁.Busy Or 網頁.readyState <> 4: DoEvents: Loop
Exit For
End If
Next
i = i + 1 '下一個金控股子公司
End If
Next
.Quit
End With
MsgBox Ar1 & vbLf & "存檔 " & UBound(Split(Ar1, vbLf)) + 1 & " 個完畢", , AR(1)
End Sub
Private Sub IE_Table(co_id As String)
Dim A As Object, i, k, j
Do
Set A = 網頁.Document.getElementsByTagName("table") '(12)
Loop Until Not A Is Nothing And A.Length >= 14
Set A = A(12)
With Workbooks.Add(1)
For i = 0 To A.Rows.Length - 1
k = k + 1
For j = 0 To A.Rows(i).Cells.Length - 1
.Sheets(1).Cells(k, j + 1) = A.Rows(i).Cells(j).innertexT
Next
Next
If Dir(xPath & co_id & ".xls") <> "" Then Kill (xPath & co_id & ".xls")
.SaveAs Filename:=xPath & co_id & ".xls"
.Close
End With
Ar1 = Ar1 & IIf(Ar1 <> "", vbLf, "") & co_id
End Sub

複製代碼