標題: 載入歷年股利政策 [打印本頁]

---

作者: pupai    時間: 2013-9-18 13:16     標題: 載入歷年股利政策

您好
就教各位
這一份資料是我在網路上找到的
現在我要把它修改成可以載入各股10年股利
資料下載處我已經修改過了
但我現在不會把TXT檔”合計”的資料載入
有人可以幫我嘛
謝謝!!

---

作者: GBKEE    時間: 2013-9-19 10:47

回復 1# pupai
試試看

1. Option Explicit
   
2. Const 資訊 = "個股資訊"
   
3. Const 主表 = "查詢表"
   
4. Sub 載入全部數據()
   
5.     Dim Rng As Range, e As Range
   
6.     With Sheets(主表)
   
7.         .Range(.[a4], .[a4].End(xlDown)).Offset(, 1).Resize(, 11) = ""
   
8.         For Each e In .Range(.[a4], .[a4].End(xlDown))
   
9.             數據 e
   
10.         Next
    
11.      End With
    
12. End Sub
    
13. Sub 載入個股數據()
    
14.     數據 ActiveCell
    
15.     ActiveCell.Resize(, 12).Select
    
16. End Sub
    
17. Private Sub 數據(xRng As Range)
    
18.     Dim xUrl As String
    
19.      If xRng.Parent.Name <> 主表 Then MsgBox "請選擇 " & 主表 & " 的個股編號 範圍  ": Exit Sub
    
20.      With Sheets(主表)
    
21.         If Intersect(.Range(.[a4], .[a4].End(xlDown)), xRng) Is Nothing Then MsgBox "請選擇 " & 主表 & " 的個股編號 範圍  ": Exit Sub
    
22.     End With
    
23.     xUrl = "URL;http://tw.stock.yahoo.com/d/s/dividend_" & xRng & ".html"
    
24.     With Sheets(資訊)
    
25.         If .QueryTables.Count <> 0 Then
    
26.             .QueryTables(1).Connection = xUrl
    
27.         Else
    
28.         .QueryTables.Add xUrl, .[A1]
    
29.         End If
    
30.         With .QueryTables(1)
    
31.             .WebSelectionType = xlSpecifiedTables
    
32.             .WebTables = "7,10"
    
33.             .Refresh BackgroundQuery:=False
    
34.             xRng.Cells(1, 2) = Replace(Split(.ResultRange.Cells(1, 1), " ")(0), xRng, "")
    
35.             xRng.Cells(1, 3).Resize(, 10) = Application.WorksheetFunction.Transpose(.ResultRange.Cells(6, 6).Resize(10))
    
36.             xRng.Cells(1, 3).Resize(, 10).NumberFormatLocal = "G/通用格式"
    
37.         End With
    
38.     End With
    
39.     Beep
    
40. End Sub

複製代碼

---

作者: pupai    時間: 2013-9-19 13:28

回復 2# GBKEE

感謝版大
我在研究看看

---

作者: pupai    時間: 2013-9-19 13:30

1. Sub 載入數據_全部()
   
2. Dim y&, Ym&
   
3. Set MySht = Sheets("查詢表")
   
4. y = MySht.[A65536].End(xlUp).Row:  If y < 4 Then Exit Sub
   
5. MySht.[B4:IV65536].ClearContents
   
6. MySht.[A2] = "＞＞＞＞＞資料載入中，請稍候......"
   
7. Application.ScreenUpdating = False
   
8. For Each uRng In MySht.Range("A4:A" & y)
   
9.     Ym = Ym + 1
   
10.     Application.StatusBar = "■■■執行數據載入中．" & Ym & "/" & y - 3
    
11.     If uRng <> "" Then Call 取得個股資訊
    
12. Next
    
13. MySht.Select
    
14. Application.StatusBar = False
    
15. MySht.[A2] = ""
    
16. Call 個股資訊格式設定: Beep
    
17. End Sub
    
18. 
    
19. Sub 載入數據_個股()
    
20. Set MySht = Sheets("查詢表")
    
21. Set uRng = ActiveCell
    
22. If uRng.Row < 4 Or uRng.Column > 1 Or uRng = "" Then
    
23.    MsgBox "※請先選取個股編號！":   Exit Sub
    
24. End If
    
25. Application.ScreenUpdating = False
    
26. Call 取得個股資訊: Call 個股資訊格式設定
    
27. If GetInfo = "ERR" Then uRng(1, 2) = "《無資料》"
    
28. MySht.Select
    
29. Beep
    
30. End Sub
    
31. 
    
32. Sub 查看個股資訊()
    
33. Set MySht = Sheets("查詢表")
    
34. Set uRng = ActiveCell
    
35. If uRng.Row < 4 Or uRng.Column > 1 Or uRng = "" Then
    
36.    MsgBox "※請先選取個股編號！":   Exit Sub
    
37. End If
    
38. Application.ScreenUpdating = False
    
39. Call 匯入文字檔: Call 個股資訊格式設定
    
40. If GetInfo = "ERR" Then uRng(1, 2) = "《無資料》"
    
41. End Sub
    
42. 
    
43. Sub 匯入文字檔()
    
44. Dim uObj As Object, uFF As Object
    
45. GetInfo = ""
    
46. uFile = ThisWorkbook.Path & "\TextFile\" & uRng.Text & ".txt"
    
47. If Dir(uFile) = "" Then GetInfo = "ERR": Exit Sub
    
48. Set uObj = CreateObject("Scripting.FileSystemObject")
    
49. Set uFF = uObj.OpenTextFile(uFile)
    
50. XMLText = uFF.Readall: uFF.Close:  Call 放入剪貼簿
    
51. With Sheets("個股資訊")
    
52.      Application.Goto .[A1], True:  .Cells.Clear
    
53.      .[B1].Select: .Paste: [B1].Select
    
54.      .[B1].Replace " *", "", Lookat:=xlPart
    
55. End With
    
56. End Sub
    
57. 
    
58. Sub 個股資訊格式設定()
    
59. With Sheets("個股資訊").UsedRange
    
60.      .Borders.LineStyle = 1:  .ColumnWidth = 13: .RowHeight = 13.5
    
61.      .Font.Size = 10: .Font.Name = "新明細體": .WrapText = False
    
62. End With
    
63. End Sub
    
64. 
    
65. Sub 取得個股資訊()
    
66. Dim fRng As Range, uTxt$, i&, j&, Jm%, xR As Range, xC%
    
67. uRng(1, 2).Resize(1, 40).ClearContents
    
68. xC = MySht.[IV3].End(xlToLeft).Column: If xC = 1 Then Exit Sub
    
69. Set WebSht = Sheets("個股資訊")
    
70. Call 匯入文字檔
    
71. If GetInfo = "ERR" Then uRng(1, 2) = "《無資料》": Exit Sub
    
72. If InStr(WebSht.[B1], uRng) = 0 Then uRng(1, 2) = "《無資料》": Exit Sub
    
73. '-----------------------------------------
    
74. uRng(1, 2).Value = WebSht.[B1]
    
75. uRng(1, 2).Replace uRng, ""
    
76. '-----------------------------------------
    
77. For j = 3 To xC
    
78.     uTxt = MySht.Cells(3, j): If uTxt = "" Then GoTo 101
    
79.     Set fRng = WebSht.Cells.Find(uTxt, Lookat:=xlPart)
    
80.     If fRng Is Nothing Then GoTo 101
    
81.     If uTxt = "現金股利" Or uTxt = "合計" Then
    
82.        uRng(1, j).Resize(1, 4).Value = Application.Transpose(fRng(2, 2).Resize(4, 1).Value)
    
83.     ElseIf uTxt = "每股淨值" Then
    
84.        With uRng(1, j): .Value = fRng: .Replace "每股淨值:* ", "": End With
    
85.     Else
    
86.        uRng(1, j) = fRng(1, 6)
    
87.     End If
    
88. 101: Next j
    
89. '-----------------------------------------
    
90. uRng(1, 6).Resize(1, xC).Replace "元", ""
    
91. End Sub
    
92. 
    
93. Sub 放入剪貼簿() '將取得文字放入剪貼簿
    
94. '〔剪貼簿〕設定引用項目 Microsoft Forms 2.0 Object Library
    
95. Dim DOB As New DataObject
    
96. With DOB: .Clear: .SetText XMLText: .PutInClipboard: End With
    
97. End Sub
    
98. 
    
99. Sub 清除()
    
100. If MsgBox("※確定要清除全部內容嗎？", 4 + 32 + 256) = vbNo Then Exit Sub
     
101. [B4:IV65536].ClearContents
     
102. End Sub

複製代碼

這是我昨天修改的方式
給各位參考看看

---

歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)