- 帖子
- 219
- 主題
- 24
- 精華
- 0
- 積分
- 243
- 點名
- 0
- 作業系統
- Windows10
- 軟體版本
- Office2016
- 閱讀權限
- 20
- 性別
- 女
- 註冊時間
- 2012-4-18
- 最後登錄
- 2022-2-7
 
|
不設表格名稱(抬頭),以下是修改部分資料應用
望請修正錯誤,謝謝..^___^..- 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
|
|
發表於 2013-3-30 22:45
| 
