擷取歷史股價

white5168

簡單擷取股價,讓使用者可以輸入自己所要的股票代碼後自動下載從2000/1/1到目前各股每天的歷史股價

white5168

The tool supports 2000/1/1~current date
每支股票的上市上櫃日期不一定,所以可能顯示的長短不一樣,請自行確認各股票開始上市上櫃日期

white5168

應觀眾要求,貼出程式碼,歡迎各位多多指教

在Sheet1貼的內容

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     If Target.Address = "$B$1" Then         '判斷目前使用者所輸入的位置是否在$B$1,如果是,則將B1輸入的代碼傳至GetStockPrice模組中,反之不作動作
   
3.     Call GetStockPrice(Range("B1"))         '傳入股票代碼,呼叫GetStockPrice模組
   
4.     End If
   
5. End Sub

複製代碼

在Module輸入的內容

1. Sub GetStockPrice(ByVal stockid As String)
   
2. '
   
3. ' GetStockPrice Macro
   
4. ' Amin 在 2012/5/6 錄製的巨集
   
5. 
   
6.     Call ClearQueryTablesData
   
7.    
   
8.     '透過 "外部匯入資料的方法" (就是使用QueryTabls的方法) 將歷史股價從2000/1/1到目前為止的日期,經由 Yahoo finance 抓回來存進excel活頁簿中,如果網站資料有問題,抓回來的也會是錯誤的資料
   
9.     With ActiveSheet.QueryTables.Add(Connection:= _
   
10.         "TEXT;http://ichart.finance.yahoo.com/table.csv?s=" & stockid & "&a=00&b=4&c=2000&d=" & Month(Date) & "&e=" & Day(Date) & "&f=" & Year(Date) & "&g=d&ignore=.csv" _
    
11.         , Destination:=Range("A3"))
    
12.         .Name = "stockprice"
    
13.         .FieldNames = True
    
14.         .RowNumbers = False
    
15.         .FillAdjacentFormulas = False
    
16.         .PreserveFormatting = True
    
17.         .RefreshOnFileOpen = False
    
18.         .RefreshStyle = xlOverwriteCells
    
19.         .SavePassword = False
    
20.         .SaveData = True
    
21.         .AdjustColumnWidth = True
    
22.         .RefreshPeriod = 0
    
23.         .TextFilePromptOnRefresh = False
    
24.         .TextFilePlatform = 950
    
25.         .TextFileStartRow = 1
    
26.         .TextFileParseType = xlDelimited
    
27.         .TextFileTextQualifier = xlTextQualifierDoubleQuote
    
28.         .TextFileConsecutiveDelimiter = False
    
29.         .TextFileTabDelimiter = True
    
30.         .TextFileSemicolonDelimiter = False
    
31.         .TextFileCommaDelimiter = True
    
32.         .TextFileSpaceDelimiter = False
    
33.         .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1)
    
34.         .TextFileTrailingMinusNumbers = True
    
35.         .Refresh BackgroundQuery:=False
    
36.     End With
    
37. End Sub
    
38. 
    
39. Sub ClearQueryTablesData()                          '判斷當前活頁簿中是否有前一筆的資料,若有則清除,反之直接下載股價
    
40.     Dim n As Integer                                                   
    
41.     If Range("A4") <> "" Then                       '判斷目前的活頁簿是否有資料存在, 這行可以再寫的更謹慎,歡迎各位自行修改
    
42.         n = ActiveSheet.Range("A4").End(xlDown).Row '選取目前活頁簿從A4位置到最後一行的範圍
    
43.         For Each gt In ActiveSheet.QueryTables      '選取用QueryTables抓取的每一行
    
44.             gt.Delete                               '將使用QueryTables方法所產生的行進行刪除,避免QueryTables用久了,造成系統堆積一堆QueryTables的垃圾,如此系統才不會變慢(各位應該都也感覺)
    
45.         Next
    
46.         ActiveSheet.Range("A4:G" & n).Clear         '清除所選取的資料
    
47.      End If
    
48. End Sub

複製代碼

white5168

應jsleee要求

關於大盤成交量可參考http://forum.twbts.com/thread-6750-1-2.html

white5168

diabo大大
有能力請自行寫出來用,不要在抱怨東抱怨西的