- 帖子
- 1
- 主題
- 1
- 精華
- 0
- 積分
- 1
- 點名
- 0
- 作業系統
- win xp
- 軟體版本
- 2003
- 閱讀權限
- 10
- 性別
- 男
- 註冊時間
- 2015-2-21
- 最後登錄
- 2020-2-10
|
Excel VBA抓取股票資料
VBA程式碼如下
view source
print?
001 Option Explicit
002
003 '股票類別
004 '01 水泥工業
005 '02 食品工業
006 '03 塑膠工業
007 '04 紡織纖維
008 '05 電機機械
009 '06 電器電纜
010 '07 化學生技醫療
011 '08 玻璃陶瓷
012 '09 造紙工業
013 '10 鋼鐵工業
014 '11 橡膠工業
015 '12 汽車工業
016 '13 電子工業
017 '14 建材營造
018 '15 航運業
019 '16 觀光事業
020 '17 金融保險業
021 '18 金融保險業
022 '19 綜合企業
023 '20 其他
024 '21 化學工業
025 '22 生技醫療業
026 '23 油電燃氣業
027 '24 半導體業
028 '25 電腦及週邊設備業
029 '26 光電業
030 '27 通信網路業
031 '28 電子零組件業
032 '29 電子通路業
033 '30 資訊服務業
034 '31 其他電子業
035
036 Dim Tempsheet As Excel.Worksheet
037
038 Private Sub 更新股票資料_Click()
039 抓取股票基本資料
040 End Sub
041
042 Sub 抓取股票基本資料()
043 Dim n As Integer
044 Dim StartTime
045
046 StartTime = Now
047
048 If 確認工作表存在("Temp") <> True Then
049 Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Temp"
050 End If
051
052 清除工作表 ("Sheet1")
053 清除工作表 ("Temp")
054
055 Application.ScreenUpdating = False
056
057 Set Tempsheet = Sheets("Temp")
058
059 If 取得股票資料 = 0 Then
060 MsgBox "無法抓取股票資料"
061 Exit Sub
062 End If
063
064 Application.StatusBar = "正在轉換資料，請稍後......"
065
066 With Sheet1
067 .Cells(1, 1) = "股票代碼"
068 .Cells(1, 2) = "公司名稱"
069
070 n = 取得公司間數
071 Tempsheet.Range("A1:B" & n).Copy '目前只列出股票代碼、公司名稱，如有需要其他欄位，請自行變更
072
073 .Cells(2, 1).Select
074 .Paste
075 End With
076
077 Application.StatusBar = "股票基本資料抓取完成"
078 Application.ScreenUpdating = True
079
080 MsgBox "股票基本資料下載 共花費 " & Format(Now - StartTime, "HH時mm分ss秒") & " 下載完成。" & vbCrLf & "以秒計算 共花費 " & DateDiff("s", StartTime, Now) & " 秒下載完成", vbInformation
081
082 End Sub
083
084 Sub 清除工作表(xlWSName As String)
085 Dim qyt As QueryTable
086 With Worksheets(xlWSName)
087 For Each qyt In .QueryTables
088 qyt.Delete
089 Next
090
091 .Cells.Clear
092 .Cells.ClearContents
093 End With
094 End Sub
095
096 Function 取得公司間數()
097 Dim i As Integer, j As Integer, n As Integer
098 j = 0
099 取得公司間數 = 0
100 With Tempsheet
101 n = .Cells(65536, 1).End(xlUp).Row
102 For i = 1 To n
103 If .Cells(i, 1).Value = Empty Or _
104 .Cells(i, 1).Value = "代號" Or _
105 .Cells(i, 1).Value = "公司" Then
106 j = j + 1
107 .Rows(i & ":" & i).Delete Shift:=xlUp
108 If n - j >= i Then
109 i = i - 1
110 End If
111 End If
112 Next
113 取得公司間數 = .Cells(65536, 1).End(xlUp).Row
114 End With
115 End Function
116
117 Function 取得股票資料()
118 Dim xlURL As String
119
120 Application.StatusBar = "從Web取得股票資料中，請稍後......"
121
122 xlURL = "http://mops.twse.com.tw/mops/web/ajax_t51sb01?step=1&firstin=1&TYPEK=sii" '上市 sii, 上櫃 otc
123 With Tempsheet.QueryTables.Add("URL;" & xlURL, Tempsheet.Cells(1, 1))
124 .WebFormatting = xlWebFormattingNone
125 .WebTables = "2"
126 .Refresh 0
127 If Application.Count(.ResultRange) = 0 Then
128 取得股票資料 = 0
129 Exit Function
130 End If
131 取得股票資料 = Application.Count(.ResultRange)
132 .Delete
133 End With
134 End Function
135
136 Function 確認工作表存在(xlWSName As String) As Boolean
137 On Error Resume Next
138 Dim xlTemp As Excel.Worksheet
139
140 Set xlTemp = Worksheets(xlWSName)
141 If Not xlTemp Is Nothing Then
142 確認工作表存在 = True
143 On Error GoTo 0
144 Set xlTemp = Nothing
145 Exit Function
146 End If
147
148 確認工作表存在 = False
149 On Error GoTo 0
150 Set xlTemp = Nothing
151 End Function |
|
發表於 2015-2-21 13:17
| 
