- 帖子
- 184
- 主題
- 45
- 精華
- 0
- 積分
- 407
- 點名
- 0
- 作業系統
- WIN 7
- 軟體版本
- office 2010
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2010-8-19
- 最後登錄
- 2024-11-1
|
4#
發表於 2013-9-19 13:30
| 只看該作者
- Sub 載入數據_全部()
- Dim y&, Ym&
- Set MySht = Sheets("查詢表")
- y = MySht.[A65536].End(xlUp).Row: If y < 4 Then Exit Sub
- MySht.[B4:IV65536].ClearContents
- MySht.[A2] = "＞＞＞＞＞資料載入中，請稍候......"
- Application.ScreenUpdating = False
- For Each uRng In MySht.Range("A4:A" & y)
- Ym = Ym + 1
- Application.StatusBar = "■■■執行數據載入中．" & Ym & "/" & y - 3
- If uRng <> "" Then Call 取得個股資訊
- Next
- MySht.Select
- Application.StatusBar = False
- MySht.[A2] = ""
- Call 個股資訊格式設定: Beep
- End Sub
- Sub 載入數據_個股()
- Set MySht = Sheets("查詢表")
- Set uRng = ActiveCell
- If uRng.Row < 4 Or uRng.Column > 1 Or uRng = "" Then
- MsgBox "※請先選取個股編號！": Exit Sub
- End If
- Application.ScreenUpdating = False
- Call 取得個股資訊: Call 個股資訊格式設定
- If GetInfo = "ERR" Then uRng(1, 2) = "《無資料》"
- MySht.Select
- Beep
- End Sub
- Sub 查看個股資訊()
- Set MySht = Sheets("查詢表")
- Set uRng = ActiveCell
- If uRng.Row < 4 Or uRng.Column > 1 Or uRng = "" Then
- MsgBox "※請先選取個股編號！": Exit Sub
- End If
- Application.ScreenUpdating = False
- Call 匯入文字檔: Call 個股資訊格式設定
- If GetInfo = "ERR" Then uRng(1, 2) = "《無資料》"
- End Sub
- Sub 匯入文字檔()
- Dim uObj As Object, uFF As Object
- GetInfo = ""
- uFile = ThisWorkbook.Path & "\TextFile\" & uRng.Text & ".txt"
- If Dir(uFile) = "" Then GetInfo = "ERR": Exit Sub
- Set uObj = CreateObject("Scripting.FileSystemObject")
- Set uFF = uObj.OpenTextFile(uFile)
- XMLText = uFF.Readall: uFF.Close: Call 放入剪貼簿
- With Sheets("個股資訊")
- Application.Goto .[A1], True: .Cells.Clear
- .[B1].Select: .Paste: [B1].Select
- .[B1].Replace " *", "", Lookat:=xlPart
- End With
- End Sub
- Sub 個股資訊格式設定()
- With Sheets("個股資訊").UsedRange
- .Borders.LineStyle = 1: .ColumnWidth = 13: .RowHeight = 13.5
- .Font.Size = 10: .Font.Name = "新明細體": .WrapText = False
- End With
- End Sub
- Sub 取得個股資訊()
- Dim fRng As Range, uTxt$, i&, j&, Jm%, xR As Range, xC%
- uRng(1, 2).Resize(1, 40).ClearContents
- xC = MySht.[IV3].End(xlToLeft).Column: If xC = 1 Then Exit Sub
- Set WebSht = Sheets("個股資訊")
- Call 匯入文字檔
- If GetInfo = "ERR" Then uRng(1, 2) = "《無資料》": Exit Sub
- If InStr(WebSht.[B1], uRng) = 0 Then uRng(1, 2) = "《無資料》": Exit Sub
- '-----------------------------------------
- uRng(1, 2).Value = WebSht.[B1]
- uRng(1, 2).Replace uRng, ""
- '-----------------------------------------
- For j = 3 To xC
- uTxt = MySht.Cells(3, j): If uTxt = "" Then GoTo 101
- Set fRng = WebSht.Cells.Find(uTxt, Lookat:=xlPart)
- If fRng Is Nothing Then GoTo 101
- If uTxt = "現金股利" Or uTxt = "合計" Then
- uRng(1, j).Resize(1, 4).Value = Application.Transpose(fRng(2, 2).Resize(4, 1).Value)
- ElseIf uTxt = "每股淨值" Then
- With uRng(1, j): .Value = fRng: .Replace "每股淨值:* ", "": End With
- Else
- uRng(1, j) = fRng(1, 6)
- End If
- 101: Next j
- '-----------------------------------------
- uRng(1, 6).Resize(1, xC).Replace "元", ""
- End Sub
- Sub 放入剪貼簿() '將取得文字放入剪貼簿
- '〔剪貼簿〕設定引用項目 Microsoft Forms 2.0 Object Library
- Dim DOB As New DataObject
- With DOB: .Clear: .SetText XMLText: .PutInClipboard: End With
- End Sub
- Sub 清除()
- If MsgBox("※確定要清除全部內容嗎？", 4 + 32 + 256) = vbNo Then Exit Sub
- [B4:IV65536].ClearContents
- End Sub
給各位參考看看 |
|
發表於 2013-9-19 10:47
| 
