麻辣家族討論版版 - Powered by Discuz! Board

標題: Excel VBA抓取股票資料 [打印本頁]

作者: elufa 時間: 2015-2-21 13:17 標題: 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

作者: budinlong 時間: 2015-3-14 17:20

報告elufa，不能執行，有很多指令和空白會卡住

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