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

Option Explicit
Sub 公開資訊觀測站()
Dim Ie As Object, xx, k, j, i, AA As Variant
Dim T As Date
ActiveSheet.Cells.Clear
Application.DisplayStatusBar = True
On Error GoTo ie_err
Set Ie = CreateObject("InternetExplorer.Application")
Ie.Navigate "http://mops.twse.com.tw/mops/web/t51sb08"
Ie.Visible = True
Do While Ie.Busy Or Ie.ReadyState <> 4: DoEvents: Loop
'********** 修改這裡的選項
Ie.Document.ALL(632).Value = "sii" '上市 = sii,上櫃 = otc,興櫃 = rotc,公開發行 = pub
Ie.Document.ALL(643).Value = "101" '年度
Ie.Document.ALL(650).Value = "04" '第一季 = 01,第二季 = 02,第三季 = 03,第四季 = 04
Ie.Document.ALL(667).Click
Ie.Visible = False
網頁整理
Set AA = Ie.Document.getelementsbytagname("table") '資料區
' Ie.Quit
T = Time
Application.ScreenUpdating = False
With ActiveSheet
On Error Resume Next
For xx = 13 To AA.Length - 1
For i = 0 To AA(xx).Rows.Length - 1 '寫入資料
k = k + 1
For j = 0 To 19
.Cells(k, 1).Select
Application.StatusBar = "下載資料中 ..." & k - 1
.Cells(k, j + 1) = AA(xx).Rows(i).Cells(j).innertext
Next
Next
Next
Set AA = .Range("S2:S" & .[S2].End(xlDown).Row)
AA.Replace "基本每股盈餘", "", xlWhole
AA.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
.Cells(.Rows.Count, 1).End(xlUp).EntireRow.Delete
ActiveWindow.ScrollRow = .Cells(.Rows.Count, 1).End(xlUp).Row - 20
.Cells(.Rows.Count, 1).End(xlUp).Select
End With
Application.ScreenUpdating = True
'Ie.Quit
Application.StatusBar = "下載資料時間 : " & Format(Time - T, ["S秒"])
End
ie_err:
MsgBox "網頁有問題,請重新執行..."
Set Ie = Nothing
End Sub
Private Sub 網頁整理() '等待網頁下載資料完畢的時間
Dim Tt(1 To 3) As Date
Tt(1) = Time
Tt(2) = Time
Tt(3) = #12:00:10 AM# '10秒調整這裡
Do
If Time > Tt(2) Then
Application.StatusBar = "網頁下載中剩餘秒數.. " & Second(Tt(1) + Tt(3) - Time)
Tt(2) = Time
End If
DoEvents
Loop Until Time > Tt(1) + Tt(3)
Application.StatusBar = "資料下載中...."
End Sub

複製代碼

這網頁有修改控制項,2# 這些程式碼不適用, 4#的程式碼已修改為正確
Ie.Document.ALL(632).Value = "sii" '上市 = sii,上櫃 = otc,興櫃 = rotc,公開發行 = pub
Ie.Document.ALL(643).Value = "101" '年度
Ie.Document.ALL(650).Value = "04" '第一季 = 01,第二季 = 02,第三季 = 03,第四季 = 04
Ie.Document.ALL(667).Click

複製代碼

Option Explicit
Sub 公開資訊觀測站()
Dim ie As Object, xx, k, j, i, AA As Variant
Dim T As Date, 資訊 As String
Do
資訊 = InputBox("1: 損益表" & vbLf & "2: 合併損益表") '選擇公開資訊觀測站的表格
'資訊 = InputBox("1: 損益表" & vbLf & "2: 合併損益表"& vbLf & "3: ???表"...............)
If 資訊 = "" Then Exit Sub '不選擇結束程式
Loop Until Val(資訊) > 0 And Val(資訊) <= 2 ' Val(資訊)<=??? 結束選擇表單
ActiveSheet.Cells.Clear
Application.DisplayStatusBar = True
Application.StatusBar = "....... 網頁開啟中.......... "
' On Error GoTo ie_err
Set ie = CreateObject("InternetExplorer.Application")
ie.Navigate 下載網址(資訊)
Do While ie.Busy Or ie.ReadyState <> 4
DoEvents
Loop
With ie.Document
T = Time
Do While ie.Busy Or ie.ReadyState <> 4
If Time = T + #12:01:00 AM# Then GoTo ie_err '等候網頁異常:結束程式
DoEvents
Loop
'********** 修改這裡的選項
.getelementbyID("TYPEK").Value = "sii" '上市 = sii,上櫃 = otc,興櫃 = rotc,公開發行 = pub
.getelementbyID("year").Value = "101" '年度
.getelementbyID("season").Value = "02" '第一季 = 01,第二季 = 02,第三季 = 03,第四季 = 04
For i = 0 To .getelementsbytagname("input").Length - 1
If .getelementsbytagname("input")(i).Type = "button" And .getelementsbytagname("input")(i).Value = " 搜尋 " Then
.getelementsbytagname("input")(i).Click
End If
Next
等待網頁
Set AA = .getelementsbytagname("table") '資料區
End With
T = Time
With ActiveSheet
.Cells(1, "A") = IIf(資訊 = 1, "損益表", "合併損益表")
.Cells(1, "B") = 市場別(ie.Document.getelementbyID("TYPEK").Value)
.Cells(1, "C") = ie.Document.getelementbyID("year").Value & "年度"
.Cells(1, "D") = ie.Document.getelementbyID("season").Value & "季"
.Cells(1).Select
Application.ScreenUpdating = False
k = 1
On Error Resume Next
For xx = 網頁表格(資訊) To AA.Length - 1
For i = 0 To AA(xx).Rows.Length - 1 '寫入資料
k = k + 1
For j = 0 To 19
Application.StatusBar = "下載資料中 ..." & k - 1
.Cells(k, j + 1) = AA(xx).Rows(i).Cells(j).innertext
Next
Next
Next
Set AA = .Range("S3:S" & .[S3].End(xlDown).Row)
AA.Replace "基本每股盈餘", "", xlWhole
AA.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
.Cells(.Rows.Count, 1).End(xlUp).EntireRow.Delete
.Cells.EntireColumn.AutoFit
.[A1].Select
End With
Application.ScreenUpdating = True
ie.Quit
Application.StatusBar = "下載資料時間 : " & Format(Time - T, ["S秒"])
End
ie_err:
ie.Quit
MsgBox "網頁有問題,請重新執行..."
End
資訊_Err:
End Sub
Private Sub 等待網頁() '等待網頁下載資料完畢的時間
Dim Tt(1 To 3) As Date
Tt(1) = Time
Tt(2) = Time
Tt(3) = #12:00:10 AM# '10秒調整這裡
Do
If Time > Tt(2) Then
Application.StatusBar = "網頁下載中剩餘秒數.. " & Second(Tt(1) + Tt(3) - Time)
Tt(2) = Time
End If
DoEvents
Loop Until Time > Tt(1) + Tt(3)
Application.StatusBar = "資料下載中...."
End Sub
Private Function 下載網址(xWord As String) As String '傳回選擇的網址
Select Case xWord
Case "1"
下載網址 = "http://mops.twse.com.tw/mops/web/t51sb08" '損益表
Case "2"
下載網址 = "http://mops.twse.com.tw/mops/web/t51sb13" '合併損益表
''Case "3" 新網頁的網址
''
''
End Select
End Function
Private Function 市場別(xWord As String) As String
'上市 = sii,上櫃 = otc,興櫃 = rotc,公開發行 = pub
Select Case xWord
Case "sii"
市場別 = "上市"
Case "otc"
市場別 = "上櫃"
Case "rotc"
市場別 = "興櫃"
Case "pub"
市場別 = "公開發行"
End Select
End Function
Private Function 網頁表格(xWord As String) As Integer
Select Case xWord
Case "1"
網頁表格 = 13 '損益表
Case "2"
網頁表格 = 12 '合併損益表
''每一網頁的表單建置不一樣,需一一去尋找
'' 自行查看新增 Case "3"......
''
End Select
End Function

複製代碼

Option Explicit
Sub 申報轉讓()
Dim ie As Object, xx, k, j, i, AA As Variant
Dim T As Date, 資訊 As String
Do
資訊 = InputBox("1: 歷史持股轉讓" & vbLf & "2: 合併損益表") '選擇公開資訊觀測站的表格
If 資訊 = "" Then Exit Sub '不選擇結束程式
Loop Until Val(資訊) > 0 And Val(資訊) <= 2 ' Val(資訊)<=??? 結束選擇表單
ActiveSheet.Cells.Clear
Application.DisplayStatusBar = True
Application.StatusBar = "....... 網頁開啟中.......... "
'On Error GoTo ie_err
Set ie = CreateObject("InternetExplorer.Application")
ie.Navigate 下載網址(資訊)
Do While ie.Busy Or ie.ReadyState <> 4
DoEvents
Loop
With ie.Document
T = Time
Do While ie.Busy Or ie.ReadyState <> 4
If Time = T + #12:01:00 AM# Then GoTo ie_err '等候網頁異常:結束程式
DoEvents
Loop
'********** 修改這裡的選項
'http://mops.twse.com.tw/mops/web/t56sb21_q3?&step=0&firstin=1&off=1&TYPEK=sii&year=91&smonth=07&emonth=09
.getelementbyID("TYPEK").Value = "sii" '上市 = sii,上櫃 = otc,興櫃 = rotc,公開發行 = pub
.getelementbyID("year").Value = "91" '年度
.getelementbyID("smonth").Value = "07" '起月份
.getelementbyID("emonth").Value = "09" '訖月份
For i = 0 To .getelementsbytagname("input").Length - 1
If .getelementsbytagname("input")(i).Type = "button" And .getelementsbytagname("input")(i).Value = " 搜尋 " Then
.getelementsbytagname("input")(i).Click
End If
Next
等待網頁
Set AA = .getelementsbytagname("table") '資料區
End With
T = Time
With ActiveSheet
.Cells(1).Select
Application.ScreenUpdating = False
k = 1
On Error Resume Next
For xx = 網頁表格(資訊) To AA.Length - 1
For i = 0 To AA(xx).Rows.Length - 1 '寫入資料
k = k + 1
For j = 0 To 19
Application.StatusBar = "下載資料中 ..." & k - 1
.Cells(k, j + 1) = AA(xx).Rows(i).Cells(j).innertext
Next
Next
Next
Set AA = .Range("R3:R" & .[R3].End(xlDown).Row)
AA.Replace "是否申報持", "", xlWhole
AA.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
.Cells(.Rows.Count, 1).End(xlUp).EntireRow.Delete
.Cells.EntireColumn.AutoFit
.[A1].Select
End With
Application.ScreenUpdating = True
ie.Quit
Application.StatusBar = "下載資料時間 : " & Format(Time - T, ["S秒"])
End
ie_err:
ie.Quit
MsgBox "網頁有問題,請重新執行..."
End
資訊_Err:
End Sub
Private Sub 等待網頁() '等待網頁下載資料完畢的時間
Dim Tt(1 To 3) As Date
Tt(1) = Time
Tt(2) = Time
Tt(3) = #12:00:10 AM# '10秒調整這裡
Do
If Time > Tt(2) Then
Application.StatusBar = "網頁下載中剩餘秒數.. " & Second(Tt(1) + Tt(3) - Time)
Tt(2) = Time
End If
DoEvents
Loop Until Time > Tt(1) + Tt(3)
Application.StatusBar = "資料下載中...."
End Sub
Private Function 下載網址(xWord As String) As String '傳回選擇的網址
Select Case xWord
Case "1"
下載網址 = "http://mops.twse.com.tw/mops/web/t56sb21_q3" '歷史持股轉讓
Case "2"
下載網址 = "http://mops.twse.com.tw/mops/web/t51sb13" '合併損益表
''Case "3" 新網頁的網址
''
''
End Select
End Function
Private Function 市場別(xWord As String) As String
'上市 = sii,上櫃 = otc,興櫃 = rotc,公開發行 = pub
Select Case xWord
Case "sii"
市場別 = "上市"
Case "otc"
市場別 = "上櫃"
Case "rotc"
市場別 = "興櫃"
Case "pub"
市場別 = "公開發行"
End Select
End Function
Private Function 網頁表格(xWord As String) As Integer
Select Case xWord
Case "1"
網頁表格 = 11
Case "2"
網頁表格 = 12 '合併損益表
''每一網頁的表單建置不一樣,需一一去尋找
'' 自行查看新增 Case "3"......
''
End Select
End Function

複製代碼

Sub 抓財報(財報別, 市場別, 年, 季)
Select Case 財報別
Case "損益": 程式 = "ajax_t51sb08"
Case "資產": 程式 = "ajax_t51sb07"
Case "合併損益": 程式 = "ajax_t51sb13"
Case "合併資產": 程式 = "ajax_t51sb12"
End Select
Select Case 市場別
Case "上市": 市場 = "sii"
Case "上櫃": 市場 = "otc"
Case "興櫃": 市場 = "rotc"
Case "公開": 市場 = "pub"
End Select
'原始網址 http://mops.twse.com.tw/mops/web/ajax_t51sb07?encodeURIComponent=1&step=1&firstin=1&off=1&TYPEK=sii&year=101&season=04
theURL = "http://mops.twse.com.tw/mops/web/" & 程式 & "?encodeURIComponent=1&step=1&firstin=1&off=1&TYPEK=" & 市場 & "&year=" & 年 & "&season=" & 季
With ActiveSheet.QueryTables.Add(Connection:="URL;" & theURL, Destination:=Range("A1"))
.Name = "抓財報"
.BackgroundQuery = True
.RefreshStyle = xlOverwriteCells
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
.Delete
End With
End Sub

複製代碼

Option Explicit
Sub Ex()
Dim ie As Object, aa As Object, k As Integer, xx As Integer, i As Integer, j As Integer
ActiveSheet.Cells.Clear
Set ie = CreateObject("InternetExplorer.Application")
ie.Navigate "http://mops.twse.com.tw/mops/web/ajax_t51sb13?step=1&firstin=1&off=1&TYPEK=sii&year=100&season=04"
Do While ie.Busy Or ie.ReadyState <> 4: DoEvents: Loop
On Error Resume Next
Set aa = ie.Document.getelementsbytagname("table") '表格資料區
k = 1
On Error Resume Next
For xx = 0 To aa.Length - 1
'找到後修改 For xx = ??? To aa.Length - 1
For i = 0 To aa(xx).Rows.Length - 1 '寫入資料
Cells(k, 1) = "Table" & xx
k = k + 1 '列數
For j = 0 To 19
Application.StatusBar = "下載資料中 ..." & k - 1
Cells(k, j + 2) = aa(xx).Rows(i).Cells(j).innertext
Next
Next
Next
ie.Quit
End Sub

複製代碼

k = 1
47. On Error Resume Next
48. For xx = 網頁表格(資訊) To AA.Length - 1
49. For i = 0 To AA(xx).Rows.Length - 1 '寫入資料
50. k = k + 1
51. For j = 0 To 19
52. Application.StatusBar = "下載資料中 ..." & k - 1
53. .Cells(k, j + 1) = AA(xx).Rows(i).Cells(j).innertext
54. Next
55. Next
56. Next

複製代碼

10. k = 1
11. On Error Resume Next
12. For xx = 0 To aa.Length - 1
13. '不同網頁，判別方式 '找到後修改 For xx = ??? To aa.Length - 1
14. For i = 0 To aa(xx).Rows.Length - 1 '寫入資料
15. Cells(k, 1) = "Table" & xx
16. k = k + 1 '列數
17. For j = 0 To 19
18. Application.StatusBar = "下載資料中 ..." & k - 1
19. Cells(k, j + 2) = aa(xx).Rows(i).Cells(j).innertext
20. Next
21. Next
22. Next

複製代碼