- 帖子
- 96
- 主題
- 18
- 精華
- 0
- 積分
- 125
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Office 2007
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2014-3-23
- 最後登錄
- 2022-8-2
|
86#
發表於 2017-6-15 22:01
| 只看該作者
回復 85# GBKEE
不好意思，我執行後似乎會卡在圖中的迴圈，不知能否請您執行看看是否有一樣情形呢？
- 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/FMSRFK/FMSRFKMAIN.php"
- ' .Visible = True '不顯示ie
- Do While .Busy Or .readyState <> 4: DoEvents: Loop
- End With
- End Sub
- Sub 上市月成交資訊()
- Dim Rng As Range, Rng1 As Range, E As Range, X As Range, T As Date, xPath As String, xFile As String
- Dim Ea As Variant, ar(), ii, aa As Integer
- T = Time
- Application.DisplayStatusBar = True
- '請將上市的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
- Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
- Set Rng1 = ThisWorkbook.Sheets(3).Range("b:b")
- If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
- If Application.Count(Rng1) = 0 Then MsgBox "沒有股票代號": Exit Sub
- Set Rng = Rng.SpecialCells(xlCellTypeConstants)
- Set Rng1 = Rng1.SpecialCells(xlCellTypeConstants)
- xPath = "F:\財報資料"
- IE_Application '
- Application.StatusBar = " "
- For Each E In Rng
- MR:
- With Sheets(1)
- .Activate
- .Cells.Clear '下載資料置於此工作表,變換股票時:清空
- End With
- For Each X In Rng1
- With IE
- .Document.getElementsByTagName("select")("Yy").Value = X
- 'yy -> 年度,mm -> 月份, dd -> 日期
- .Document.getelementsbyname("stockNo")(0).Value = E
- '股票代碼 stockNo '**大小寫要一致**
- ' .Document.getelementsbyname("query-button")(0).Click '按下查詢
- For Each Ea In .Document.body.all.tags("a")
- If Ea.classname = "button search" Then
- Ea.Click: Exit For '按下查詢
- End If
- Next
- Do While .Busy Or .readyState <> 4: Loop
- On Error Resume Next
- If InStr(.Document.getElementsByTagName("TABLE")(3).outerHTML, "查無") Then GoTo Nn
- If .Document.getElementsByTagName("TABLE")(3).Rows.Length > 1 Then
- Ep .Document.getElementsByTagName("TABLE")(3).outerHTML
- Else
- GoTo Nn
- End If
- ' If InStr(Selection.Cells(3, 1), "查無") Then Selection.Delete Shift:=xlUp: GoTo Nn
- End With
- With Sheets(1)
- aa = Selection.Range("a3")
- ' If aa = "" Then aa = Selection.Range("a1") '會出錯才加入這段
- If aa + 1911 <> X Then GoTo MR
- End With
- Next X
- Nn:
- If Sheets(1).Range("a1") = "" Then GoTo KK
- xFile = xPath & "\" & E & "\HPM.txt"
- MkDir_Sub xFile
- Maketxt xFile, Sheets(1).Range("A1").CurrentRegion, E.Value
- ii = ii + 1
- Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 匯入上市月成交 " & E & "共" & ii & " 文字檔"
- KK:
- Next E
- IE.Quit
- Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上市月成交 " & ii & " 文字檔, 讀取完畢 !! "
- MsgBox "匯入 文字檔" & ii & " 費時 " & Application.Text(Time - T, ["MM分SS秒"])
- ' ThisWorkbook.Save
- End Sub
- Sub Ep(S As String)
- Dim D As New DataObject, i As Integer, FormDLL As String, Rng As Range
- 'DataObject 物件 在進行轉換動作時，做為格式化文字資料的暫存區域。其也可以暫存和儲存在 DataObject 的文字片段相關的格式。
- '宣告 Dim D As New DataObject '須在工具-> 設定引用項目加入 新增引用 Microsoft Forms 2.0 Object Library ,專案 加入一表單即可
- On Error GoTo ER
- With D
- .SetText S
- .PutInClipboard
- With Sheets(1)
- With .Range("a" & .Rows.Count).End(xlUp)
- If .Row = 1 Then
- Set Rng = .Cells
- Else
- Set Rng = .Offset(1)
- End If
- Rng.Select
- .Parent.PasteSpecial Format:="Unicode 文字"
- Set Rng = Rng.Range("A3", Rng.Range("A3").End(xlDown)).Resize(, 9)
- With Sheets(1).Sort
- .SetRange Rng
- .Header = xlGuess
- .MatchCase = False
- .Orientation = xlTopToBottom
- .SortMethod = xlPinYin
- .Apply
- End With
- 'Sort :資料排序
- ' Rng.Sort Key1:=Rng.Range("B2"), Order1:=xlDescending, Header:=xlYes ', _
- OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
- :=xlStroke, DataOption1:=xlSortNorma
- ' If .Row = 1 Then
- ' .Range("A2").EntireRow.Delete
- ' Else
- ' .Range("A2:A4").EntireRow.Delete
- ' End If
- End With
- End With
- End With
- Exit Sub
- ER:
- ThisWorkbook.VBProject.References.AddFromFile "C:\windows\system32\FM20.DLL"
- Resume
- End Sub
- Sub Maketxt(xF As String, Q As Range, Code As String) '將匯入資料存入指定的txt
- Dim fs As Object, E As Range, C As Variant, A As String, B As Integer, D As String
- Set fs = CreateObject("Scripting.FileSystemObject")
- Set fs = fs.CreateTextFile(xF, True) '創見一個檔案,如檔案存在可覆蓋掉
- A = Q.Cells(1)
- B = Len(A)
- If B >= 25 Then
- D = Mid(A, 11, 4)
- Else
- D = Mid(A, 11, 2)
- End If
- Q.Cells(1) = Code & "-" & D & "" & " 月成交資料" '加入股票代號
- If Q.Cells(3, 1).Offset(1) = "" Then GoTo EE
- Q.Range("a3", Q.Range("a3").End(xlDown)).Replace "年度", ""
- Q.Columns(1).SpecialCells(xlCellTypeBlanks).Offset(-1).EntireRow.Delete
- Q.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
- EE:
- For Each E In Q.Rows
- C = Application.Transpose(Application.Transpose(E.Value))
- C = Join(C, vbTab)
- fs.Write 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
 上市月成交資訊.zip (39.22 KB)
|
|
發表於 2015-2-11 16:10
| 
