- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
43#
發表於 2014-4-30 10:27
| 只看該作者
本帖最後由 GBKEE 於 2014-4-30 10:30 編輯
回復 42# smart3135
WEB 查詢請 版上有許多討論 可搜尋 http://www.twse.com.tw/ch/trading/exchange/FMNPTK/FMNPTKMAIN.php 這字串
上市與 上櫃 網頁的建置不同- Option Explicit
- Dim IE As Object
- Sub IE_Application()
- Set IE = CreateObject("InternetExplorer.Application")
- With IE
- .Navigate "http://www.twse.com.tw/ch/trading/exchange/FMNPTK/FMNPTKMAIN.php"
- .Visible = True '顯示ie
- Do While .Busy Or .ReadyState <> 4: DoEvents: Loop
- End With
- End Sub
- Sub 上市年成交資訊()
- Dim E As Range, xPath As String, xFile As String, A As Object, fs As Object, F As Object, IE_URL As String
- Dim i As Integer, ii As Integer, t As Date, AR(), Rng As Range, r, C, S
- Set fs = CreateObject("Scripting.FileSystemObject")
- IE_URL = "http://www.twse.com.tw/ch/trading/exchange/FMNPTK/FMNPTKMAIN.php"
- t = Time
- Application.DisplayStatusBar = True
- Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
- If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
- Set Rng = Rng.SpecialCells(xlCellTypeConstants)
- '你已將上市的股票代號,在Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
- xPath = "D:\財報資料"
- IE_Application '
- Application.StatusBar = " "
- Sheets(1).Activate
- For Each E In Rng
- With IE
- Do While .Busy Or .ReadyState <> 4: Loop
- Set A = .Document.getelementbyid("STK_NO")
- A.Value = E
- .Document.getelementSbyNAME("login_btn")(0).Click '按下查詢
- Do While .Busy Or .ReadyState <> 4: Loop
- Set A = .Document.getelementsbytagname("TABLE")
- xFile = xPath & "\" & E & "\HPM.txt"
- MkDir_Sub xFile
- With Sheets(1)
- .Cells.Clear
- For i = 1 To A(7).Rows.Length - 1
- For C = 0 To A(7).Rows(i).Cells.Length - 1
- .Cells(i, C + 1) = A(7).Rows(i).Cells(C).innertext
- Next
- Next
- .UsedRange.Sort Key1:=.Range("A2"), Order1:=xlDescending, Header:=True '排序:xlDescending ( 由大至小 )
- Maketxt xFile, .UsedRange
- End With
- ii = ii + 1
- End With
- Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & " 共匯入上市年成交 " & ii & " 文字檔"
- Next
- IE.Quit
- Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & " 共匯入上市年成交 " & ii & " 文字檔, 讀取完畢 !! "
- MsgBox "匯入 文字檔" & ii & " 費時 " & Application.Text(Time - t, ["MM分SS秒"])
- ThisWorkbook.Save
- End Sub
- Sub Maketxt(xF As String, Q As Range) '*** Q As Range ****
- Dim fs As Object, E As Range, C As Variant
- Set fs = CreateObject("Scripting.FileSystemObject")
- Set fs = fs.CreateTextFile(xF, True) '創見一個檔案,如檔案存在可覆蓋掉
- For Each E In Q.Rows '修改這 Q.ResultRange.Rows
- C = Application.Transpose(Application.Transpose(E.Value))
- C = Join(C, vbTab)
- fs.WriteLine C
- Next
- fs.Close
- End Sub
- Sub MkDir_Sub(S As String)
- Dim AR, i As Integer, xPath As String
- If Dir(S) = "" Then
- AR = Split(S, "\")
- xPath = AR(0)
- For i = 1 To UBound(AR) - 1
- xPath = xPath & "\" & AR(i)
- If Dir(xPath, vbDirectory) = "" Then MkDir xPath
- Next
- End If
- End Sub
|
|
發表於 2014-5-4 06:02
| 
