返回列表 上一主題 發帖

[分享] 大盤每月每天歷史成交量與金額下載

[分享] 大盤每月每天歷史成交量與金額下載

本帖最後由 white5168 於 2012-5-31 00:43 編輯

繼上次各股股價歷史資料下載,再一次分享 大盤歷史成交量下載
附件有 "大盤每月歷史成交量與金額下載" 檔, 歡迎各位先進試用看看
如有問題歡迎告知以便於修改,程式碼待大家覺得不錯用時,會稍後補上

大盤成交量下載.rar (19.38 KB)

大盤每月歷史成交量與金額下載

本帖最後由 white5168 於 2012-6-23 22:57 編輯

在Sheet1的程式碼
  1. Private Sub 大盤成交資訊_Click()
  2.     Dim Year As String
  3.     Dim Mon As String
  4.    
  5.     Year = Format(Range("C1"), "0000")  '修改字串格式
  6.     Mon = Format(Range("C2"), "00")     '修改字串格式
  7.     Call Run(Year, Mon)                 '呼叫Module1中的函數
  8. End Sub
複製代碼
在Module1的程式碼
  1. Sub Run(Year As String, Month As String)
  2.     Dim sheetName As String
  3.     sheetName = "Temp"
  4.    
  5.     If CheckSheetExist(sheetName) <> True Then      '確定Temp工作表是否存在,若不存在則呼叫AddTempSheet建立Temp工作表
  6.         Call AddTempSheet(sheetName)
  7.     End If
  8.    
  9.     Call ClearTempTablesData(sheetName)             '避免Temp工作表存在時資料格式未清除,而清除
  10.     Call GetPrice(sheetName, Year, Month)           '從TWSE取得大盤歷史資料
  11.     Call ClearsheetTablesData("Sheet1")             '清除原本在Sheet1工作表的資料
  12.     Call SetCellWidthSize(sheetName)                '設定TWSE取得的資料所造成的格式,將此格式調整為excel預設的儲存格格式
  13.     Call CopyDatatoSheet(sheetName)                 '將Temp工作表資料拷貝至Sheet1工作表
  14.     Call DeleteTempSheet(sheetName)                 '刪除Temp工作表   
  15.     Sheets("Sheet1").Select                         '將focus設定到Sheet1工作表
  16. End Sub

  17. Function CheckSheetExist(sheetName As String) As Boolean
  18.     Dim i As Integer
  19.     CheckSheetExist = False
  20.     For i = 1 To Worksheets.Count                   '取得目前工作表的數量
  21.         If sheetName = Worksheets(i).Name Then      '判斷指定的工作表名稱是否存在,存在則回傳找到工作表的訊息
  22.             CheckSheetExist = True                  '將找到的訊息設定至回傳值
  23.         End If
  24.     Next
  25. End Function

  26. Sub AddTempSheet(sheetName As String)
  27.     ActiveWorkbook.Worksheets.Add After:=Worksheets(Worksheets.Count)   '建立指定工作到現存工作表的對後面
  28.     Worksheets(Worksheets.Count).Select                                 '選擇建立工作表
  29.     ActiveSheet.Name = sheetName                                        '修改工作表名稱
  30. End Sub

  31. Sub GetPrice(sheetName As String, Year As String, Month As String)
  32.    
  33.     Sheets(sheetName).UsedRange.Select              '選取指定工作表A1:H50的儲存格範圍
  34.     Selection.Clear                                 '清除所選取儲存格格式
  35.     Selection.ClearContents                         '清除所選取的資料
  36.     Sheets(sheetName).Range("A1").Select            '選取Temp工作表A1儲存格,避免使用QueryTable後,因為資料擠壓會造成儲存格右移,導致foucs不在A1儲存格上而發生錯誤訊息
  37.    

  38.     '以下就不多介紹,Excel相關內容
  39.     With ActiveSheet.QueryTables.Add(Connection:= _
  40.         "TEXT;http://www.twse.com.tw/ch/trading/exchange/FMTQIK/FMTQIK2.php?STK_NO=&myear=" & Year & "&mmon=" & Month & "&type=csv", _
  41.         Destination:=Range("A1"))
  42.         .Name = "大盤歷史資料"
  43.         .FieldNames = True
  44.         .RowNumbers = False
  45.         .FillAdjacentFormulas = False
  46.         .PreserveFormatting = True
  47.         .RefreshOnFileOpen = False
  48.         .RefreshStyle = xlInsertDeleteCells
  49.         .SavePassword = False
  50.         .SaveData = True
  51.         .AdjustColumnWidth = True
  52.         .RefreshPeriod = 0
  53.         .TextFilePromptOnRefresh = False
  54.         .TextFilePlatform = 950
  55.         .TextFileStartRow = 1
  56.         .TextFileParseType = xlDelimited
  57.         .TextFileTextQualifier = xlTextQualifierDoubleQuote
  58.         .TextFileConsecutiveDelimiter = False
  59.         .TextFileTabDelimiter = False
  60.         .TextFileSemicolonDelimiter = False
  61.         .TextFileCommaDelimiter = True
  62.         .TextFileSpaceDelimiter = False
  63.         .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
  64.         .TextFileTrailingMinusNumbers = True
  65.         .Refresh BackgroundQuery:=False                             '若沒有 Sheets(sheetName).Range("A1").Select,在此行會發生錯誤
  66.         If Err.Number <> 0 Then Err.Clear: MsgBox "資料查詢失敗"    '被免資料抓取不成功,而顯示訊息
  67.     End With
  68. End Sub

  69. Sub SetCellWidthSize(sheetName As String)
  70.     Dim n As Integer
  71.     Worksheets(sheetName).Select
  72.     n = ActiveSheet.Range("A1").End(xlDown).Row             '取得選取有存在資料的儲存格列數
  73.     ActiveSheet.Range("A1:F" & n).UseStandardWidth = True   '設定指定工作表的儲存格寬度為預設值
  74. End Sub
  75. Sub CopyDatatoSheet(sheetName As String)
  76.     Dim n As Integer
  77.    
  78.     Worksheets(sheetName).Select                            '選取指定名稱工作表
  79.     n = ActiveSheet.Range("A3").End(xlDown).Row - 1         '取得選取有存在資料的儲存格列數
  80.     ActiveSheet.Range("A3:F" & n).Copy                      '複製選取的儲存格資料
  81.    
  82.     Worksheets("Sheet1").Select                             '選取Sheet1工作表
  83.     Range("A5").Select                                      '選取A5儲存格
  84.     ActiveSheet.Paste                                       '貼上資料   
  85. End Sub

  86. Sub ClearsheetTablesData(sheetName As String)
  87.     Dim n As Integer
  88.     Dim qyt As QueryTable
  89.    
  90.     Worksheets(sheetName).Select
  91.     If ActiveSheet.Range("A5") <> "" Then                   '判斷目前的活頁簿是否有資料存在, 這行可以再寫的更謹慎,歡迎各位自行修改
  92.         n = ActiveSheet.Range("A5").End(xlDown).Row         '選取目前活頁簿從A4位置到最後一行的範圍
  93.         For Each qyt In ActiveSheet.QueryTables             '選取用QueryTables抓取的每一行
  94.             qyt.Delete                                      '將使用QueryTables方法所產生的行進行刪除,避免QueryTables用久了,造成系統堆積一堆QueryTables的垃圾,如此系統才部會變慢
  95.         Next
  96.         ActiveSheet.Range("A5:G" & n).Clear                 '清除所選取儲存格格式
  97.         ActiveSheet.Range("A5:G" & n).ClearContents         '清除所選取的資料
  98.     Else
  99.         ActiveSheet.Range("A5:G40").Clear                   '清除所選取儲存格格式
  100.         ActiveSheet.Range("A5:G40").ClearContents           '清除所選取的資料
  101.     End If
  102. End Sub

  103. Sub DeleteTempSheet(sheetName As String)
  104.     Worksheets(sheetName).Select
  105.     Application.DisplayAlerts = False                       '關閉警告視窗
  106.     Worksheets(sheetName).Delete                            '刪除作用中的工作表
  107.     Application.DisplayAlerts = True                        '恢復警告視窗
  108. End Sub

  109. Sub ClearTempTablesData(sheetName As String)
  110.     Dim n As Integer
  111.     Dim qyt As QueryTable
  112.    
  113.     Worksheets(sheetName).Select                            '選取指定名稱工作表
  114.     If ActiveSheet.Range("A1") <> "" Then
  115.         n = ActiveSheet.Range("A1").End(xlDown).Row         '選取目前活頁簿從A1位置到最後一行的範圍
  116.         For Each qyt In Worksheets(sheetName).QueryTables   '選取用QueryTables抓取的每一行
  117.             qyt.Delete                                      '將使用QueryTables方法所產生的行進行刪除,避免QueryTables用久了,造成系統堆積一堆QueryTables的垃圾,如此系統才部會變慢
  118.         Next
  119.         ActiveSheet.Range("A1:F" & n).Clear                 '清除所選取儲存格格式
  120.         ActiveSheet.Range("A1:F" & n).ClearContents         '清除所選取的資料
  121.     Else
  122.         ActiveSheet.UsedRange.Clear                         '清除所選取儲存格格式
  123.         ActiveSheet.UsedRange.ClearContents                 '清除所選取的資料
  124.     End If
  125. End Sub
複製代碼

TOP

本帖最後由 GBKEE 於 2012-6-24 08:41 編輯

回復 2# white5168
要分享記得專案請不要不上鎖
SHEET1的程式碼
  1. Private Sub 大盤成交資訊_Click()
  2.     Dim xlTheYear As String, xlTheMonth As String, xlTheFile As String
  3.     xlTheYear = Format(Range("C1"), "0000")  '修改字串格式
  4.     xlTheMonth = Format(Range("C2"), "00")     '修改字串格式
  5.     UsedRange.Offset(4).Clear
  6.     xlTheFile = "http://www.twse.com.tw/ch/trading/exchange/FMTQIK/FMTQIK2.php?STK_NO=&myear=" & xlTheYear & "&mmon=" & xlTheMonth & "&type=csv"
  7.     With Workbooks.Open(xlTheFile)
  8.         .Sheets(1).UsedRange.Offset(2).Copy [a5]
  9.         .Close 0
  10.     End With
  11. End Sub
複製代碼

TOP

本帖最後由 white5168 於 2012-6-23 23:03 編輯

版主,請問有自行確認過以上程式碼是可以將資料成功產生在sheet1嗎?

TOP

回復 4# white5168
試試看

    大盤每月每天歷史..rar (7.64 KB)

TOP

回復 3# GBKEE
蠻不錯的寫法!
一支 Private Sub 大盤成交資訊_Click() 就完成了所有的作業。

TOP

回復 7# usana642
1.複製程式碼到 一般模駔,或 ThisWorkbook模駔    2.在工作表上 插入快取圖案,   3.將圖案的巨集指定此程序
於工作表 的 C1 :  輸入西元年份   C2 :  輸入月份    按下 快取圖案 就可以
  1. Sub 大盤成交資訊()
  2.     Dim xlTheYear As String, xlTheMonth As String, xlTheFile As String
  3.     xlTheYear = Format(Range("C1"), "0000")  '修改字串格式
  4.     xlTheMonth = Format(Range("C2"), "00")     '修改字串格式
  5.     UsedRange.Offset(4).Clear
  6.     xlTheFile = "http://www.twse.com.tw/ch/trading/exchange/FMTQIK/FMTQIK2.php?STK_NO=&myear=" & xlTheYear & "&mmon=" & xlTheMonth & "&type=csv"
  7.     With Workbooks.Open(xlTheFile)
  8.         .Sheets(1).UsedRange.Offset(2).Copy [a5]
  9.         .Close 0
  10.     End With
  11. End Sub
複製代碼
EX1.GIF
2012-6-25 20:32

TOP

回復 4# white5168

版大辛苦簡化的程式碼,難道你沒測試看看?
枉費版大的教學
給GBKEE版主按個讚

TOP

哇!超方便的~~~
謝謝大大的分享~
尤其謝謝GBKEE版主的簡易版~~~
但小弟現在有一個問題...要怎麼寫出一個程式,需求是:
下載完後的資料,自動儲存到另一個SHEET(總表),
下載另一時期的資料後,再自動儲存在總表內空白儲存格?
並且是向下儲存這樣?

TOP

回復 9# turbine
  1. Option Explicit
  2. Private Sub 大盤成交資訊()
  3.     Dim xlTheYear As String, xlTheMonth As String, xlTheFile As String
  4.     Dim Sh As Worksheet
  5.     xlTheYear = Format(Range("C1"), "0000")  '修改字串格式
  6.     xlTheMonth = Format(Range("C2"), "00")   '修改字串格式
  7.     Set Sh = ThisWorkbook.Sheets.Add         '新增工作表
  8.     Sh.Name = xlTheYear & "_" & xlTheMonth   '新增工作表命名
  9.     xlTheFile = "http://www.twse.com.tw/ch/trading/exchange/FMTQIK/FMTQIK2.php?STK_NO=&myear=" & xlTheYear & "&mmon=" & xlTheMonth & "&type=csv"
  10.     With Workbooks.Open(xlTheFile)
  11.         .Sheets(1).UsedRange.Copy Sh.[a1]
  12.         .Close 0
  13.     End With
  14.     Sh.Cells.EntireColumn.AutoFit            '調整欄寬
  15.     Sh.Columns("A:A").ColumnWidth = 28.56
  16. End Sub
複製代碼

TOP

        靜思自在 : 修行要繫緣修心,藉事練心,隨處養心。
返回列表 上一主題