- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
7#
發表於 2012-8-4 11:32
| 只看該作者
本帖最後由 GBKEE 於 2012-8-5 09:23 編輯
回復 1# white5168
測試 完成圖
2012/8/5 更新程式碼
- Option Explicit
- Dim SH(1 To 2) As Worksheet, IE As Object
- Dim xltheCsv As String, xLMsg As String, Rng As Range
- Const xlPath = "D:\Test1\" '可修改CSV存檔的路徑
- Sub 全部日報表() '查詢全部日股票報表
- Dim T As Date
- 存檔資料夾
- T = Time
- xLMsg = "" '紀錄 股票代號沒報表
- 上市股票代號 '取得最新上市股票代號表
- 網頁 '開啟網頁
- Set Rng = SH(1).[A3] '股票代號
- Do
- Rng.Select
- ActiveWindow.ScrollRow = Rng.Row - 1
- Application.ScreenUpdating = False
- If Rng.Offset(, 1) <> "" Then 匯入日報表 Trim(Split(Rng, " ")(0)) 'Trim(Split(Rng, " ")(0)):股票代號
- Set Rng = Rng.Offset(1) '下一個 股票代號
- Application.ScreenUpdating = True
- 'Loop Until Rng = "" '<-含 上市股票,上市認購(售)權證,受益證券-不動產投資信託--
- Loop Until Rng.Offset(, 1) = "" '<-僅有 上市股票 : B欄是空白時離開迴圈
- SH(1).Parent.Close 0 '關閉 最新上市股票代號表
- IE.Quit '關閉 網頁
- Set IE = Nothing
- Set Rng = Nothing
- MsgBox "全部日報表下載完成 費時" & Format(T - Time, "HH時mm分ss秒") & Chr(10) & xLMsg
- If xLMsg <> "" Then 無報表紀錄
- End Sub
- Sub 查詢股票日報表() '查詢單一股票日報表
- Dim 股票代號 As String, 股票 As String, T As Date
- 存檔資料夾
- xLMsg = ""
- Do While 股票代號 = ""
- 股票代號 = InputBox("股票代號", "輸入查詢之股票代號", "1101")
- If 股票代號 = "" Then End
- Loop
- T = Time
- 網頁
- 匯入日報表 股票代號
- IE.Quit
- Set IE = Nothing
- If xLMsg <> "" Then
- MsgBox xLMsg
- 無報表紀錄
- Exit Sub
- Else
- 股票 = Replace(Replace(xltheCsv, ".CSV", ""), xlPath, "")
- MsgBox 股票 & Chr(10) & "下載時間" & Format(T - Time, "HH時mm分ss秒") _
- & Chr(10) & "存檔路徑: " & xlPath
- End If
- Workbooks.Open xltheCsv
- ActiveSheet.Cells.EntireColumn.AutoFit
- End Sub
- Private Sub 匯入日報表(股票代號 As String) '處裡傳送來的 --股票代號--
- Dim Xall As Integer, SubMsg As String, SubRng As Range
- Xall = Val(報表頁數(股票代號)) '傳回報表頁數
- If Xall = 0 Then '無報表頁數: 報表不存在
- If Rng Is Nothing Then
- SubMsg = "[ " & 股票代號 & " ] 無報表"
- Else '全部日報表程式: 含股票名稱
- SubMsg = Rng & " 無報表"
- End If
- xLMsg = IIf(xLMsg <> "", xLMsg & Chr(10) & SubMsg, SubMsg)
- Exit Sub
- End If
- Set SH(2) = Workbooks.Add(1).Sheets(1) '新增一活頁簿
- With SH(2).QueryTables.Add(Connection:="URl;http://bsr.twse.com.tw/bshtm/bsContent.aspx?StartNumber=" & 股票代號 & "&FocusIndex=All_" & Xall, Destination:=SH(2).Range("A1"))
- .WebFormatting = xlWebFormattingNone
- .WebTables = "4,""table2"""
- On Error Resume Next '程式還有錯誤不處裡
- Do
- Err.Clear '清除錯誤值
- .Refresh BackgroundQuery:=False 'Refresh 失敗 會有錯誤值
- Loop While Err > 0 '有錯誤值繼續迴圈 直到 Refresh 成功
- On Error GoTo 0 '有錯誤值 不處裡
- '消除: On Error Resume Next 如還有錯誤不處裡 會影響運行的正確性
- SH(2).Names(.Name).Delete
- End With
- If Xall > 1 Then '處裡頁數 > 1 '清理空白列及 每頁的欄位
- With SH(2)
- Set SubRng = .Range(.[A6], .Cells(.Rows.Count, "A").End(xlUp))
- SubRng.Replace "序", "", xlWhole
- SubRng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete xlUp
- End With
- End If
- xltheCsv = xlPath & Format(SH(2).[B1], "yyyy_mm_dd ") & SH(2).[F1] & ".CSV"
- On Error GoTo xlerr 'xltheCsv 已開啟會有錯誤 到xLerr處裡
- If Dir(xltheCsv) <> "" Then Kill xltheCsv
- On Error GoTo 0
- SH(2).Parent.SaveAs xltheCsv, xlCsv
- SH(2).Parent.Close True
- Exit Sub
- xlerr:
- If Err = 70 Then
- Workbooks(Format(SH(2).[B1], "yyyy_mm_dd ") & SH(2).[F1] & ".CSV").Close 0 '關閉xltheCsv 可清除錯誤
- Resume '反回錯誤行
- Else
- MsgBox "錯誤值 " & Err & " 需偵錯!!"
- End
- End If
- End Sub
- Private Sub 上市股票代號() '下載最新代號 ( 上市股票,上市認購(售)權證,受益證券-不動產投資信託 )
- Dim SstockId As String
- SstockId = "URL;http://brk.twse.com.tw:8000/isin/C_public.jsp?strMode=2"
- Set SH(1) = Workbooks.Add(1).Sheets(1)
- With SH(1).QueryTables.Add(SstockId, SH(1).[A1])
- .WebFormatting = xlWebFormattingNone
- .WebTables = "2"
- .Refresh 0
- End With
- End Sub
- Private Sub 網頁() '開啟網頁
- Dim Url As String
- Set IE = CreateObject("InternetExplorer.Application")
- Url = "http://bsr.twse.com.tw/bshtm/bsMenu.aspx"
- With IE
- '.Visible = False ''可以不顯示 IE
- .Visible = True
- .Navigate "http://bsr.twse.com.tw/bshtm/bsMenu.aspx"
- Do While .Busy Or .ReadyState <> 4
- DoEvents
- Loop
- End With
- End Sub
- Private Sub 存檔資料夾() '沒有CSV存檔的路徑: 設立CSV存檔的路徑
- If Dir(xlPath, vbDirectory) = "" Then MkDir xlPath
- End Sub
- Private Sub 無報表紀錄() '工作表上紀錄 沒報表的股票代號
- With ThisWorkbook.Sheets(1)
- .Activate
- If .[A1] = "" Then .[A1] = "股票: 無報表"
- .Cells(.Rows.Count, "a").End(xlUp).Offset(1).Resize(UBound(Split(xLMsg, Chr(10))) + 1) = Application.Transpose(Split(xLMsg, Chr(10)))
- End With
- End Sub
- Private Function 報表頁數(Sstock_N0 As String)
- Dim element As Object
- On Error GoTo xlerr:
- xlAgain:
- Set element = IE.Document.getElementsByName("txtTASKNO")
- element.Item(0).Value = Sstock_N0
- Set element = IE.Document.getElementsByName("btnOK")
- element.Item(0).Click
- With IE
- Do While .Busy Or .ReadyState <> 4
- DoEvents
- Loop
- End With
- Set element = IE.Document.getElementsByName("sp_ListCount")
- 報表頁數 = element.Item(0).innertext
- Exit Function
- xlerr: '處裡網頁中斷
- IE.Quit
- 網頁
- Err.Clear
- GoTo xlAgain
- End Function
|
|
發表於 2012-8-3 00:35
| 
