Board logo

標題: [分享] 大盤每月每天歷史成交量與金額下載 [打印本頁]
作者: white5168    時間: 2012-5-30 23:47     標題: 大盤每月每天歷史成交量與金額下載

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

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

本帖最後由 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

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

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

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

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

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

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

  110. Sub DeleteTempSheet(sheetName As String)
  111.     Worksheets(sheetName).Select
  112.     Application.DisplayAlerts = False                       '關閉警告視窗
  113.     Worksheets(sheetName).Delete                            '刪除作用中的工作表
  114.     Application.DisplayAlerts = True                        '恢復警告視窗
  115. End Sub

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

本帖最後由 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
複製代碼
作者: white5168    時間: 2012-6-23 22:41

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

版主,請問有自行確認過以上程式碼是可以將資料成功產生在sheet1嗎?
作者: GBKEE    時間: 2012-6-24 08:10

回復 4# white5168
試試看

    [attach]11473[/attach]
作者: c_c_lai    時間: 2012-6-24 08:29

回復 3# GBKEE
蠻不錯的寫法！
一支 Private Sub 大盤成交資訊_Click() 就完成了所有的作業。
作者: GBKEE    時間: 2012-6-25 20:33

回復 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
複製代碼
[attach]11488[/attach]
作者: white945    時間: 2012-8-11 23:55

回復 4# white5168

版大辛苦簡化的程式碼，難道你沒測試看看?
枉費版大的教學
給GBKEE版主按個讚
作者: turbine    時間: 2012-10-1 11:35

哇！超方便的~~~
謝謝大大的分享~
尤其謝謝GBKEE版主的簡易版~~~
但小弟現在有一個問題...要怎麼寫出一個程式，需求是：
下載完後的資料，自動儲存到另一個SHEET（總表），
下載另一時期的資料後，再自動儲存在總表內空白儲存格？
並且是向下儲存這樣？
作者: GBKEE    時間: 2012-10-2 10:52

回復 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
複製代碼
作者: usana642    時間: 2012-10-17 11:19

回復 10# GBKEE

太讚了
非常感謝GBKEE大大的熱心分享
作者: usana642    時間: 2012-10-17 11:40

回復 10# GBKEE

謝謝GBKEE的熱心分享
我試過發現,下載的資料都儲存在A欄位,請問要如何改成以下資料格式儲存,謝謝您
A欄     B欄           C欄       D欄       E欄          F欄          G欄
日期  成交股數  成交金額  成交筆數  發行量  加權股價指數  漲跌點數
作者: GBKEE    時間: 2012-10-17 12:02

回復 12# usana642
作用中的工作表  C1 有輸入 年度嗎? C2 有輸入 月份嗎?
附上你的 檔案看看
作者: usana642    時間: 2012-10-17 17:15

回復 13# GBKEE

謝謝GBKEE大大的回覆
下載的資料都儲存在A欄位,
例如
100/07/01,"3,799,797,589","109,887,443,287","821,716","8,739.82",87.23


請問要如何改成以下資料格式儲存,以及把""號去除
A欄                 B欄                        C欄                      D欄           E欄                 F欄            
日期               成交股數                成交金額                 成交筆數      加權股價指數    漲跌點數
100/07/01     3,799,797,589    109,887,443,287    821,716       8,739.82        87.23   


[attach]12807[/attach]
作者: GBKEE    時間: 2012-10-17 17:30

回復 14# usana642
正常啊沒你說的問題,會是你IE有問題嗎?
早上我的IE 也有問題,看這網頁修改了.
http://tw.knowledge.yahoo.com/question/question?qid=1509082302506
作者: usana642    時間: 2012-10-17 18:02

回復 15# GBKEE

謝謝GBKEE大大的回覆

我的電腦可以執行程式,下載資料都OK,我的問題是當天的數值都放在A欄位
例如
100/07/01,"3,799,797,589","109,887,443,287","821,716","8,739.82",87.23--->全匯入在A欄位

我想把當天數值分開放在每一單獨欄位上,
A欄                 B欄                        C欄                      D欄           E欄                 F欄           
100/07/01     3,799,797,589    109,887,443,287    821,716       8,739.82        87.23

附上圖說明,第一列是原來格式,我想改成第四列的格式,謝謝您的熱心回覆
作者: GBKEE    時間: 2012-10-17 18:12

本帖最後由 GBKEE 於 2012-10-17 18:15 編輯

回復 16# usana642
我的電腦可以執行程式,下載資料都OK,我的問題是當天的數值都放在A欄位

這不對的 我下載完成的是你所要的有分欄的
100年08月市場成交資訊(元,股)                                       
日期        成交股數        成交金額        成交筆數        發行量加權股價指數        漲跌點數
100/08/01        4,802,873,133        134,792,140,188        1,045,023        8,701.38        57.2
100/08/02        4,460,257,070        128,697,790,897        983,452        8,584.72        -116.66
100/08/03        5,242,190,864        147,151,600,336        1,158,419        8,456.86        -127.86
100/08/04        5,107,533,580        141,508,869,343        1,125,390        8,317.27        -139.59
100/08/05        5,994,797,600        162,619,243,835        1,209,399        7,853.13        -464.14
100/08/08        6,146,181,315        168,324,584,613        1,289,476        7,552.80        -300.33
100/08/09        7,587,824,872        202,710,492,435        1,544,718        7,493.12        -59.68
100/08/10        6,265,027,298        179,518,452,401        1,423,133        7,736.32        243.2
100/08/11        5,424,476,208        153,879,609,456        1,275,107        7,719.09        -17.23
作者: usana642    時間: 2012-10-17 19:14

回復 17# GBKEE

非常謝謝GBKEE大大的耐心回覆
再次感謝您
作者: usana642    時間: 2012-10-18 08:49

回復 15# GBKEE


   好像是IE6出問題,我的是WINXP SP3要重裝IE6真麻煩,謝謝GBKEE提供的資訊
作者: usana642    時間: 2012-10-18 13:09

回復 19# usana642

  請問GBKEE大大
我還沒處理好IE6的問題,剛才我試了您寫的另一個程式,發現欄位都正常,這讓我迷惑了,望指導,謝謝您

http://forum.twbts.com/viewthrea ... p;extra=&page=2

結果如下


交易日期        2012/10/17                        股票代號        1101 台泥                               
成交筆數        3,038        成交金額        337,561,131                成交股數        9,181,447                       
開盤價        36.8        最高價        36.9        最低價        36.6        收盤價        36.9               
                                                                       
序        證券商        成交單價        買進股數        賣出股數        序        證券商        成交單價        買進股數        賣出股數
1        1020 合  庫        36.65        0        8,000        2        1020        36.7        0        20,000
3        1020        36.75        0        102,000        4        1020        36.8        0        2,000
5        1021 合庫台中        36.7        0        10,000        6        1022 合庫台南        36.8        0        5,000
7        1023 合庫高雄        36.8        0        1,000        8        1024 合庫嘉義        36.75        1,000        1,000
9        102C 合庫自強        36.75        0        5,000        10        102C        36.8        0        5,000
11        102D 合庫港都        36.9        0        20,000        12        1031 土銀台中        36.75        0        2,000
13        1031        36.8        0        1,000        14        1032 土銀台南        36.7        0        10,000
15        1032        36.75        0        13,000        16        1033 土銀高雄        36.7        1,000        0
17        1033        36.8        3,000        0        18        1034 土銀嘉義        36.8        0        9,000
19        1035 土銀新竹        36.8        0        2,000        20        1036 土銀玉里        36.75        10,000        0
21        1037 土銀花蓮        36.8        0        1,000        22        1039 土銀士林        36.9        0        1,000
23        1040 臺 銀        36.7        0        4,000        24        1040        36.8        0        4,000
25        1041 臺銀鳳山        36.7        0        1,000        26        1041        36.8        1,000        0
27        1042 臺銀臺南        36.9        0        1,000        28        1043 臺銀民權        36.7        0        33,000
作者: GBKEE    時間: 2012-10-18 14:35

回復 20# usana642
那是匯入外部資料, 這是開啟Excel  csv   文字檔,有些不同的
你試著開啟一 Excel  csv 文字檔,如有你說資料皆在A欄,那就可能是EXCEL的問題.
作者: usana642    時間: 2012-10-18 16:48

回復 21# GBKEE

我再試看看,謝謝您
作者: usana642    時間: 2012-10-18 17:41

回復 21# GBKEE

謝謝GBKEE大大
我是用EXCEL 2000,
再請教您一個問題,我用 WEB查詢的方式,將下列網站數據存入工作表一中,當我要在工作表二,計算"最後成交價"乘上"未沖銷契約量"時,表格中的無數據符號"-",會造成錯誤
#VALUE! ,請問要如何在無數據的欄位把它當成0處裡,以方便計算
   
http://www.taifex.com.tw/chinese/3/3_2_2.asp
作者: GBKEE    時間: 2012-10-18 17:54

本帖最後由 GBKEE 於 2012-10-18 17:56 編輯

回復 23# usana642
  1. Option Explicit
  2. 用 2000版 以上試試看
  3. Sub Ex()
  4.      Columns(8).Replace "-", ""
  5.      '或是
  6.      Range("H:H").Replace "-", "0"
  7. End Sub
複製代碼
作者: usana642    時間: 2012-10-18 19:15

回復 24# GBKEE


    謝謝您
作者: usana642    時間: 2012-10-18 20:34

回復 24# GBKEE

請問GBKEE大大

我在"計算"工作表的兩個欄位 "call-oi$" "put-oi$",要完成上述問題的數據計算,請問要如何修正?謝謝您的協助
作者: GBKEE    時間: 2012-10-19 10:16

回復 26# usana642
試試看
  1. Option Explicit
  2. Sub Ex()
  3.     With ActiveSheet
  4.         .Cells.Clear
  5.         With .QueryTables.Add("URL;http://www.taifex.com.tw/chinese/3/3_2_2.asp", ActiveSheet.[A1])
  6.             .WebFormatting = xlWebFormattingNone
  7.             .Refresh BackgroundQuery:=False
  8.             ActiveSheet.Names(.Name).Delete
  9.         End With
  10.         .Range("E:G,I:L,N:Q").Delete                                    '刪除多餘的欄
  11.         .Range("1:6,8:8").Delete                                        '刪除多餘的列
  12.         .Range("B1").End(xlDown).Offset(1).Resize(2).EntireRow.Delete   '刪除多餘的列
  13.         .Range("A:A").Insert                                            '插入一欄
  14.         .[B1].Resize(, 12) = Array("契約", "月份", "履約價", "買賣權", "成交價", "未平倉量", "CALL", "=C2", "call-oi", "put-oi", "call-oi$", "put-oi$")
  15.         '**  "=C2" 可修改為 正確的參照  ***
  16.         With .Range("b2", .[b2].End(xlDown))
  17.             .Offset(, -1) = "=rc4 +rc8 + rc9"
  18.             .Columns(5).Replace "-", ""
  19.             .Columns(7) = "=IF(rc[-3]=""Call"",1,0)"    'R1C1表示法 : 工作表上腧入公式
  20.             .Columns(8) = "=IF(rc[-6]=r1c9,1,8)"
  21.             .Columns(9) = "=IF(rc[-2]=1,rc[-3],0)"
  22.             .Columns(10) = "=IF(rc[-3]=0,rc[-4],0)"
  23.             .Columns(11) = "=if(rc[-1]=0,rc[-6]*rc[-5],"""")"
  24.             .Columns(12) = "=if(rc[-2]<>0,rc[-7]*rc[-6],"""")"
  25.         End With
  26.         .UsedRange.Value = .UsedRange.Value             '消除公式
  27.         .Columns.AutoFit
  28.     End With
  29. End Sub
複製代碼
作者: usana642    時間: 2012-10-19 10:35

回復 27# GBKEE


   可以正常執行了
非常感謝GBKEE大大的熱心協助,謝謝您
作者: usana642    時間: 2012-10-19 12:33

回復 27# GBKEE

GBKEE大大真抱歉
我自己新增加一些東西,還有以下問題
1.可否在''計算''的工作表中第278列加上加總的計算?這一列是否會隨資料源每月變動而變動?
2.在''計算''的工作表中已加上"更新"這個按鈕來控制更新,按下後,資料進來,但是按鈕不見了?

請問要如何修正?謝謝您撥空指導,謝謝...
作者: GBKEE    時間: 2012-10-19 12:36

本帖最後由 GBKEE 於 2012-10-19 12:58 編輯

回復 29# usana642
但是按鈕不見了?

[attach]12829[/attach]


27# 加入程式碼
  1. With .Range("b2", .[b2].End(xlDown))
  2.             .Offset(, -1) = "=rc4 +rc8 + rc9"
  3.             .Columns(5).Replace "-", ""
  4.             .Columns(7) = "=IF(rc[-3]=""Call"",1,0)"    'R1C1表示法 : 工作表上腧入公式
  5.             .Columns(8) = "=IF(rc[-6]=r1c9,1,8)"
  6.             .Columns(9) = "=IF(rc[-2]=1,rc[-3],0)"
  7.             .Columns(10) = "=IF(rc[-3]=0,rc[-4],0)"
  8.             .Columns(11) = "=if(rc[-1]=0,rc[-6]*rc[-5],"""")"
  9.             .Columns(12) = "=if(rc[-2]<>0,rc[-7]*rc[-6],"""")"
  10.              With .Cells(.Rows.Count + 1, 1) '.Rows.Count + 1 範圍內資料總列數+1
  11.                 .Cells(1, 0) = "小計"
  12.                 .Cells(1, 6) = Application.Sum(.Parent.Columns(6))
  13.                 .Cells(1, 9) = Application.Sum(.Parent.Columns(9))
  14.                 .Cells(1, 10) = Application.Sum(.Parent.Columns(10))
  15.                 .Cells(1, 11) = Application.Sum(.Parent.Columns(11))
  16.                 .Cells(1, 12) = Application.Sum(.Parent.Columns(12))
  17.             End With
  18.         End With
複製代碼
作者: usana642    時間: 2012-10-19 15:17

回復 30# GBKEE

已正常執行
真的非常感謝GBKEE大大的熱心幫忙,謝謝您
作者: usana642    時間: 2012-10-19 20:00

回復 30# GBKEE


GBKEE大大,我剛剛執行程式,發現小計算出的數值都不正確,請問要修改哪裡?不好意思再麻煩您幫忙,謝謝您
  1. Option Explicit
  2. Private Sub 更新()
  3.     With ActiveSheet
  4.         .Cells.Clear
  5.         With .QueryTables.Add("URL;http://www.taifex.com.tw/chinese/3/3_2_2.asp", ActiveSheet.[A1])
  6.             .WebFormatting = xlWebFormattingNone
  7.             .Refresh BackgroundQuery:=False
  8.             ActiveSheet.Names(.Name).Delete
  9.         End With
  10.         .Range("E:G,I:L,N:Q").Delete                                    '刪除多餘的欄
  11.         .Range("1:6,8:8").Delete                                        '刪除多餘的列
  12.         .Range("B1").End(xlDown).Offset(1).Resize(2).EntireRow.Delete   '刪除多餘的列
  13.         .Range("A:A").Insert                                            '插入一欄
  14.         .[B1].Resize(, 12) = Array("契約", "月份", "履約價", "買賣權", "成交價", "未平倉量", "CALL", "=C2", "call-oi", "put-oi", "call-oi$", "put-oi$")
  15.         '**  "=C2" 可修改為 正確的參照  ***
  16.         With .Range("b2", .[b2].End(xlDown))
  17.             .Offset(, -1) = "=rc4 +rc8 + rc9"
  18.             .Columns(5).Replace "-", ""
  19.             .Columns(7) = "=IF(rc[-3]=""Call"",1,0)"    'R1C1表示法 : 工作表上腧入公式
  20.             .Columns(8) = "=IF(rc[-6]=r1c9,1,8)"
  21.             .Columns(9) = "=IF(rc[-2]=1,rc[-3],0)"
  22.             .Columns(10) = "=IF(rc[-3]=0,rc[-4],0)"
  23.             .Columns(11) = "=if(rc[-1]=0,rc[-6]*rc[-5],"""")"
  24.             .Columns(12) = "=if(rc[-2]<>0,rc[-7]*rc[-6],"""")"
  25.         End With
  26.         .UsedRange.Value = .UsedRange.Value             '消除公式
  27.         .Columns.AutoFit
  28.         With .Range("b2", .[b2].End(xlDown))
  29.             .Offset(, -1) = "=rc4 +rc8 + rc9"
  30.             .Columns(5).Replace "-", ""
  31.             .Columns(7) = "=IF(rc[-3]=""Call"",1,0)"    'R1C1表示法 : 工作表上腧入公式
  32.             .Columns(8) = "=IF(rc[-6]=r1c9,1,8)"
  33.             .Columns(9) = "=IF(rc[-2]=1,rc[-3],0)"
  34.             .Columns(10) = "=IF(rc[-3]=0,rc[-4],0)"
  35.             .Columns(11) = "=if(rc[-1]=0,rc[-6]*rc[-5],"""")"
  36.             .Columns(12) = "=if(rc[-2]<>0,rc[-7]*rc[-6],"""")"
  37.              With .Cells(.Rows.Count + 1, 1) '.Rows.Count + 1 範圍內資料總列數+1
  38.                 .Cells(1, 0) = "小計"
  39.                 .Cells(1, 6) = Application.Sum(.Parent.Columns(6))
  40.                 .Cells(1, 9) = Application.Sum(.Parent.Columns(9))
  41.                 .Cells(1, 10) = Application.Sum(.Parent.Columns(10))
  42.                 .Cells(1, 11) = Application.Sum(.Parent.Columns(11))
  43.                 .Cells(1, 12) = Application.Sum(.Parent.Columns(12))
  44.             End With
  45.         End With
  46.     End With
  47. End Sub
複製代碼
作者: GBKEE    時間: 2012-10-19 20:26

回復 32# usana642
不好意思沒詳細檢查,更正如下
  1. Option Explicit
  2. Private Sub 更新()
  3.     Dim Rng As Range
  4.     With ActiveSheet
  5.         .Cells.Clear
  6.         With .QueryTables.Add("URL;http://www.taifex.com.tw/chinese/3/3_2_2.asp", ActiveSheet.[A1])
  7.             .WebFormatting = xlWebFormattingNone
  8.             .Refresh BackgroundQuery:=False
  9.             ActiveSheet.Names(.Name).Delete
  10.         End With
  11.         .Range("E:G,I:L,N:Q").Delete                                    '刪除多餘的欄
  12.         .Range("1:6,8:8").Delete                                        '刪除多餘的列
  13.         .Range("B1").End(xlDown).Offset(1).Resize(2).EntireRow.Delete   '刪除多餘的列
  14.         .Range("A:A").Insert                                            '插入一欄
  15.         .[B1].Resize(, 12) = Array("契約", "月份", "履約價", "買賣權", "成交價", "未平倉量", "CALL", "=C2", "call-oi", "put-oi", "call-oi$", "put-oi$")
  16.         '**  "=C2" 可修改為 正確的參照  ***
  17.         With .Range("b2", .[b2].End(xlDown))
  18.             .Offset(, -1) = "=rc4 +rc8 + rc9"
  19.             .Columns(5).Replace "-", ""
  20.             .Columns(7) = "=IF(rc[-3]=""Call"",1,0)"    'R1C1表示法 : 工作表上腧入公式
  21.             .Columns(8) = "=IF(rc[-6]=r1c9,1,8)"
  22.             .Columns(9) = "=IF(rc[-2]=1,rc[-3],0)"
  23.             .Columns(10) = "=IF(rc[-3]=0,rc[-4],0)"
  24.             .Columns(11) = "=if(rc[-1]=0,rc[-6]*rc[-5],"""")"
  25.             .Columns(12) = "=if(rc[-2]<>0,rc[-7]*rc[-6],"""")"
  26.         End With
  27.         .UsedRange.Value = .UsedRange.Value             '消除公式
  28.         .Columns.AutoFit
  29.         Set Rng = .Range("b2", .[b2].End(xlDown))
  30.         With Rng
  31.             .Offset(, -1) = "=rc4 +rc8 + rc9"
  32.             .Columns(5).Replace "-", ""
  33.             .Columns(7) = "=IF(rc[-3]=""Call"",1,0)"    'R1C1表示法 : 工作表上腧入公式
  34.             .Columns(8) = "=IF(rc[-6]=r1c9,1,8)"
  35.             .Columns(9) = "=IF(rc[-2]=1,rc[-3],0)"
  36.             .Columns(10) = "=IF(rc[-3]=0,rc[-4],0)"
  37.             .Columns(11) = "=if(rc[-1]=0,rc[-6]*rc[-5],"""")"
  38.             .Columns(12) = "=if(rc[-2]<>0,rc[-7]*rc[-6],"""")"
  39.              With .Cells(.Rows.Count + 1, 1) '.Rows.Count + 1 範圍內資料總列數+1
  40.                 .Cells(1, 0) = "小計"
  41.                 .Cells(1, 6) = Application.Sum(Rng.Columns(6))
  42.                 .Cells(1, 9) = Application.Sum(Rng.Columns(9))
  43.                 .Cells(1, 10) = Application.Sum(Rng.Columns(10))
  44.                 .Cells(1, 11) = Application.Sum(Rng.Columns(11))
  45.                 .Cells(1, 12) = Application.Sum(Rng.Columns(12))
  46.             End With
  47.         End With
  48.     End With
  49. End Sub
複製代碼
作者: usana642    時間: 2012-10-19 20:35

回復 33# GBKEE


    謝謝GBKEE大大的快速回應,可以正確算出小計了,再次感謝您的熱心協助,祝您週末愉快...
作者: c_c_lai    時間: 2012-10-20 07:45

回復 30# GBKEE
對不起，請教您 "快取圖案格式" 功能欄 我要如何才能找到？
我是 2010 版。因這案例處理或許我會碰上。
作者: GBKEE    時間: 2012-10-20 07:52

回復 35# c_c_lai
按右鍵

    [attach]12832[/attach]
作者: c_c_lai    時間: 2012-10-20 08:14

回復 36# GBKEE
真奇，沒看到呦？
[attach]12833[/attach]
又、以下的語法實在是有看沒懂，我一直想了解它們代表的含意：
  1.             .Columns(7) = "=IF(rc[-3]=""Call"",1,0)"        ' R1C1表示法 : 工作表上腧入公式
  2.             .Columns(8) = "=IF(rc[-6]=r1c9,1,8)"
  3.             .Columns(9) = "=IF(rc[-2]=1,rc[-3],0)"
  4.             .Columns(10) = "=IF(rc[-3]=0,rc[-4],0)"
  5.             .Columns(11) = "=if(rc[-1]=0,rc[-6]*rc[-5],"""")"
  6.             .Columns(12) = "=if(rc[-2]<>0,rc[-7]*rc[-6],"""")"
複製代碼
我將 =IF(rc[-3]=""Call"",1,0) 貼到任一欄位想觀察結果，
結果該欄的值卻是整段 =IF(rc[-3]=""Call"",1,0) 之字串。
作者: GBKEE    時間: 2012-10-20 08:49

本帖最後由 GBKEE 於 2012-10-20 08:50 編輯

回復 37# c_c_lai
會是在 [大小及內容] 中嗎?
FormulaR1C1 屬性   傳回或設定物件的公式，用巨集語言的 R1C1 樣式符號表示。Range 物件為讀/寫 Variant，Series 物件為讀/寫 String。
執行後 如圖 勾選 R1C1  便知

[attach]12835[/attach]
  1. Option Explicit
  2. Sub Ex()
  3.     Dim i
  4.     For i = 1 To 5
  5.         [c5].Cells(1, i) = "=r" & i & "c" & i
  6.         [c5].Cells(2, i) = "=r[" & i & "]c[" & i & "]"
  7.         [c5].Cells(3, i) = "=r[-" & i & "]c[-" & i & "]"
  8.     Next
  9. End Sub
複製代碼
作者: c_c_lai    時間: 2012-10-20 09:05

回復 38# GBKEE
對的！
[attach]12836[/attach]
R1C1 我會好好地去瞭解，謝謝您！
作者: c_c_lai    時間: 2012-10-20 09:53

回復 38# GBKEE
[attach]12837[/attach]
作者: reangame    時間: 2012-10-21 21:34

回復 4# white5168


    晚點再來下載看看囉~~~~
作者: turbine    時間: 2012-10-23 10:55

謝謝G版主的解決方式~~~
但其實小弟我是想要一個超偷懶方式...
年、月會自動跑
如：自1990年01月起自動下載紀錄在SHEET1後儲存，
再自動跳到1990年02月，自動下載紀錄在SHEET1內下方空白處，接續剛剛1月的資料尾
如此重覆至2012年10月這樣...
這樣是不是太懶了...一..一"
作者: usana642    時間: 2012-10-24 18:07

本帖最後由 usana642 於 2012-10-24 18:10 編輯

回復 33# GBKEE

再請教GBKEE大,我再增加一個''紀錄''工作表,把計算後的小計,自動匯入儲存,如果隔天再按''計算''工作表的''更新''按鈕後,希望能在''紀錄''工作表自動儲存當天計算後的小計結果,懇請GBKEE大大再次協助,謝謝您...
[attach]12878[/attach]
作者: usana642    時間: 2012-10-24 18:13

本帖最後由 usana642 於 2012-10-24 18:14 編輯

回復 33# GBKEE

不好意思,沒有上傳好,再上傳一次

[attach]12879[/attach]
作者: GBKEE    時間: 2012-10-24 21:48

回復 44# usana642
  1. Option Explicit
  2. Sub 儲存小計結果()
  3.     Dim Rng As Range
  4.     Set Rng = Sheets("計算").Range("G1").End(xlDown)                 'G1往下最後有資料的儲存格
  5.     With Sheets("紀錄").Cells(Rows.Count, "A").End(xlUp).Cells(2, 1)
  6.          'Cells(Rows.Count, "A").End(xlUp):A欄最後列往上有資料的儲存格.Cells(2, 1) :第2列 ,第1欄
  7.           .Value = Date
  8.           .Cells(1, 2) = Rng
  9.           .Cells(1, 3).Resize(1, 4) = Rng.Cells(1, 4).Resize(1, 4).Value
  10.     End With
  11. End Sub
複製代碼
作者: usana642    時間: 2012-10-25 09:48

回復 45# GBKEE

謝謝GBKEE的熱心協助,可以正常執行了,非常感謝您,祝您事事順心
作者: usana642    時間: 2012-10-25 13:33

本帖最後由 usana642 於 2012-10-25 13:34 編輯

回復 45# GBKEE

GBKEE午安
我想再請教您
請問如果我想在''連結''工作表中,挑選出買權和賣權的最大未平倉量,
例如24日是
賣權   履約價=7000        最後成交價=27.5  未平倉量=38191
買權   履約價=7700        最後成交價=11.5  未平倉量=57082

然後分別自動儲存在''紀錄''工作表中,每天的結果也能紀錄儲存,再次懇請您的幫忙,謝謝您
[attach]12886[/attach]
作者: GBKEE    時間: 2012-10-25 20:48

回復 47# usana642
試試看
  1. Option Explicit
  2. Sub 儲存小計結果()
  3.     Dim Rng(1 To 4) As Range, AR(1 To 6), xi As Integer, e As Variant
  4.     With Sheets("計算")
  5.         Set Rng(1) = .Range("G1").End(xlDown)                 'G1往下最後有資料的儲存格
  6.         Set Rng(2) = .Range("E2", .[E2].End(xlDown))          '買賣權
  7.     End With
  8.     For Each e In Array("Call", "Put")
  9.         Rng(2).Replace e, "=usana642"                          '公式不存在 傳回錯誤值
  10.         With Rng(2).SpecialCells(xlCellTypeFormulas, xlErrors) '有錯誤的儲存格
  11.             With .Offset(, 2)                                  '右移2欄
  12.                 xi = IIf(e = "Call", 0, 1)
  13.                 Set Rng(3) = .Find(Application.Max(.Cells))    '尋找最大值
  14.                 AR(1 + xi) = Rng(3).Offset(, -3)               '履約價
  15.                 AR(3 + xi) = Rng(3).Offset(, -1)               '最後成交價
  16.                 AR(5 + xi) = Rng(3)                            '未沖銷契約量
  17.             End With
  18.             .Value = e
  19.         End With
  20.     Next
  21.     With Sheets("紀錄").Cells(Rows.Count, "A").End(xlUp).Cells(2, 1)
  22.          'Cells(Rows.Count, "A").End(xlUp):A欄最後列往上有資料的儲存格.Cells(2, 1) :第2列 ,第1欄
  23.           .Value = Date
  24.           .Cells(1, 2) = Rng(1)
  25.           .Cells(1, 3).Resize(1, 4) = Rng(1).Cells(1, 4).Resize(1, 4).Value
  26.           .Cells(1, 7).Resize(1, 6) = AR
  27.     End With
  28. End Sub
複製代碼
作者: usana642    時間: 2012-10-26 09:14

回復 48# GBKEE

謝謝GBKEE的熱心協助,我從程式碼編輯程式執行這一段程式,已經可以正常執行,稍後我再把它整合進整個程式裡,非常感謝您的熱心幫忙,再次感謝您,祝您順利發財...
作者: usana642    時間: 2012-10-30 17:29

回復 48# GBKEE

GBKEE您好

我今天試著照您的方式,在抓取另一網頁資料時,在紀錄1工作表無法完成自動紀錄,懇請您再指導一下,謝謝您...
   
[attach]12950[/attach]
作者: GBKEE    時間: 2012-10-30 18:11

回復 51# usana642
[當日-自營商][當日-投信][當日-外資][當日-多空淨額][未平倉-自營商][未平倉-投信][未平倉-外資][未平倉-多空淨額]
這些欄位是抓取  計算1  那些的資料??
.Cells(1, 7).Resize(1, 6) = AR 程式中沒看到抓AR的資料
作者: usana642    時間: 2012-10-30 18:58

回復 52# GBKEE

GBKEE大大您好

我是想抓取計算1工作表的口數(F欄位),謝謝您
作者: usana642    時間: 2012-10-30 19:04

回復 52# GBKEE


    今天的資料是口數430,75,-5,317,-4,812,-86,017,870,-13,469,-98,616
謝謝您
作者: GBKEE    時間: 2012-10-30 21:04

回復 54# usana642
重點是
紀錄1工作表 [當日-自營商][當日-投信][當日-外資][當日-多空淨額][未平倉-自營商][未平倉-投信][未平倉-外資][未平倉-多空淨額] 這些欄位
抓取 : 計算1工作表上的那些的資料??
  1. Sub 儲存OI1()
  2. With Sheets("紀錄1").Cells(Rows.Count, "A").End(xlUp).Cells(2, 1)
  3. ' *** Sheets("紀錄1")工作表的 A1須先輸入字串"日期" ******
  4. ' *** 這行程式碼第一次執行才會到正確的位置
  5. 'Cells(Rows.Count, "A").End(xlUp):A欄最後列往上有資料的儲存格.Cells(2, 1) :第2列 ,第1欄
  6. .Resize(1, 9) = Array(Date, 2, 3, 4, 5, Sheets("紀錄1").[F14], [計算1!F14], 8, 9)
  7. 'Date 後面的 2,3,4,5,, 請自行輸入適當的位置
  8. '[計算1!F14] <=> Sheets("紀錄1").[F14] <=> Sheets("紀錄1").Range("F14")
  9. End With
  10. End Sub
複製代碼
作者: usana642    時間: 2012-10-31 10:07

回復 55# GBKEE

GBKEE大大您好

謝謝您的熱心指導,已經可以正常執行了,再次感謝您的熱心協助,祝您事事順利愉快...
作者: 198188    時間: 2012-12-2 10:03

回復 10# GBKEE


    請問如果網頁是船公司的船期表，可否做到？
作者: GBKEE    時間: 2012-12-3 08:51

回復 56# 198188
那一網頁可上傳說明,參考看看
作者: 198188    時間: 2012-12-3 09:40

回復 57# GBKEE


    [attach]13375[/attach]

請看附件，由於太多網頁，所以只有提供捷徑于您，有勞
作者: GBKEE    時間: 2012-12-3 15:49

本帖最後由 GBKEE 於 2012-12-3 15:51 編輯

回復 58# 198188
我可以幫你做的只是,vba上的語法及程式上的編寫,你傳上一堆網址,我莫宰羊啦.
重點是要有說明你想做什麼
作者: 198188    時間: 2012-12-3 16:00

回復 59# GBKEE

[attach]13380[/attach]
因為需要輸入櫃號，然後才可以去船期表那裏，然後讀取current ETA?
這個要求是不是有困難？
作者: GBKEE    時間: 2012-12-3 16:26

回復 60# 198188
如這裡一樣嗎?
那網頁在哪裡?
作者: 198188    時間: 2012-12-3 17:19

回復 61# GBKEE


第一張圖網址
http://www.maerskline.com/appmanager/

第二張圖網址
http://www.maerskline.com/appmanager/maerskline/public?_nfpb=true&_nfls=false&_pageLabel=page_tracking3_trackSimple
作者: 198188    時間: 2012-12-3 17:48

回復 61# GBKEE

可否幫我看看下面link的問題
http://forum.twbts.com/viewthrea ... a=pageD1&page=2
請問為什麼按一次後，它自動將最後那row當成下次的第一個？
因為我按一次後，把資料刪除後就在上一次執行的最後一列+1開始，可以讓它不會自動記憶，每按一次就先刪除以前的資料，然後都從A2開始。
另外我附件內另一個程式執行時很慢，有加快的方法嗎
作者: GBKEE    時間: 2012-12-4 08:13

回復 62# 198188
抱歉只能幫到 [貨櫃號碼登錄] 這裡
這http://www.maerskline.com/appmanager/maerskline/public?_nfpb=true&_nfls=false&_pageLabel=page_tracking3_trackSimple網頁
的貨物資料,一直無法下載到Excel
  1. Option Explicit
  2. Sub 貨櫃號碼登錄()
  3.    Dim IE As New InternetExplorer, i As Integer, vDoc As Object
  4.     '宣告 Dim ie As New InternetExplorer
  5.     '須在工具-> 設定引用項目加入 新增引用 Microsoft Internet Controls
  6.     'Set IE = CreateObject("InternetExplorer.Application")
  7.     'Dim i As Integer, vDoc As Object
  8.     With CreateObject("InternetExplorer.Application") '不需新增引用 Microsoft Internet Controls
  9.     'With IE
  10.         .Visible = True
  11.         .Navigate "http://www.maerskline.com/appmanager/"
  12.         Do While .Busy Or .ReadyState <> 4: DoEvents: Loop
  13.         Set vDoc = .Document.getElementsByTagName("INPUT")
  14.         For i = 0 To vDoc.Length - 1
  15.             If vDoc(i).Name = "portlet_quickentries_2{actionForm.trackNo}" Then vDoc(i).Value = "PONU4867818"  '貨櫃號碼
  16.             If vDoc(i).Value = "Track" Then vDoc(i).Click               '按下確定
  17.         Next
  18.     End With
  19. End Sub
複製代碼


    回復 63# 198188
21 # stillfish00 已提出修正 ,你試試看,真不行再說
作者: 198188    時間: 2012-12-4 09:10

回復 64# GBKEE


    非常感謝~我也知道這個想法很難做到。
另外我想問可否同時將三個不同excel名內的sheet copy 在另一個sheet上
例如：
Y:\2012\A.XLSX (2012)
C:\2012\B.XLSX (Nov)
Z:\2012\C.XLSX (2012)

copy在
C:\USER\DESTOP\E.XLSX (2012)
每次copy都會重新從A2 : AM2 到最後的資料copy下去 (最後的資料那列每次都不同）
例如：
Y:\2012\A.XLSX (2012) 的資料到從A2:AM2 to A100:AM100
C:\2012\B.XLSX (Nov) 的資料到A2:AM2 to A50:AM50
Z:\2012\C.XLSX (2012) 的資料到A2:AM2 to A120:AM120
那麼copy出來的效果是
A2:AM2 to A100:AM100 是Y:\2012\A.XLSX (2012) 的資料
A101:AM101 to A150:AM150是C:\2012\B.XLSX (Nov)的資料
A151:AM151 to A270:AM270是Z:\2012\C.XLSX (2012) 的資料
第二次按會清楚之前的資料再從A2 : AM2開始，每次都這樣
作者: GBKEE    時間: 2012-12-4 10:19

回復 65# 198188
此回覆:已是偏離這主題,以後請在有相關的主題中發問
試試看
  1. Option Explicit
  2. Sub Ex()
  3.    Dim Rng As Range
  4.    'With Workbooks.Open("C:\USER\DESTOP\E.XLSX").Sheets("2012") '檔案未開啟時用此程式碼
  5.    With Workbooks("E.XLSX").Sheets("2012")                      '檔案已開啟時用此程式碼
  6.         'A2:AM2 to A100:AM100 是Y:\2012\A.XLSX (2012) 的資料
  7.         Set Rng = .[A2]
  8.         With Workbooks.Open("Y:\2012\A.XLSX").Sheets("2012")    '檔案開啟
  9.             .[A100:AM100].Copy Rng
  10.            .Parent.Close False                                  '檔案關閉
  11.         End With
  12.         'A101:AM101 to A150:AM150是C:\2012\B.XLSX (Nov)的資料
  13.         Set Rng = .[A101]
  14.         With Workbooks.Open("Y:\2012\A.XLSX").Sheets("Nov")    '檔案開啟
  15.             .[A150:AM150].Copy Rng
  16.            .Parent.Close False                                  '檔案關閉
  17.         End With
  18.         'A151:AM151 to A270:AM270是Z:\2012\C.XLSX (2012) 的資料
  19.         Set Rng = .[A151]
  20.         With Workbooks.Open("Y:\2012\A.XLSX").Sheets("2012")    '檔案未開啟
  21.             .[A270:AM270].Copy Rng
  22.            .Parent.Close False                                  '檔案關閉
  23.         End With
  24.     End With
  25. End Sub
複製代碼
作者: 198188    時間: 2012-12-4 10:45

回復 66# GBKEE


    謝謝。
但是可以讓它自動辨認最後一筆嗎？
因為我要copy的三個excel，每天都有加資料上次，所以需要它自己辨認要copy的資料有多少筆，然後第二個就從第一個的最後一筆之後一列再開始copy
作者: GBKEE    時間: 2012-12-4 11:03

回復 67# 198188
是這樣嗎?
  1. Option Explicit
  2. Sub EX()
  3.     '
  4.     '
  5.     Set Rng = .[A2]  '第一個Rng
  6.     '
  7.     '
  8.     'Set Rng = .[A101]  '第二個Rng
  9.     '第二個Rng改成如此第一個Rng往下到有資料的下一列
  10.     Set Rng = Rng.End(xlDown).Offset(1)  '第二個Rng
  11.     '
  12.     '
  13.     'Set Rng = .[A151]  '第三個Rng
  14.     '第三個Rng改成如此第二個Rng往下到有資料的下一列
  15.     Set Rng = Rng.End(xlDown).Offset(1) '第三個Rng
  16.     '
  17.     '
  18. End Sub
複製代碼
作者: 198188    時間: 2012-12-4 11:26

回復 68# GBKEE


   對了，就是這樣，非常感謝
作者: robin0338    時間: 2013-9-8 18:54

想請問記憶體不足，這是要如何解決阿!!!
作者: pupai    時間: 2013-9-19 16:04

本帖最後由 pupai 於 2013-9-19 16:06 編輯
回復  turbine
GBKEE 發表於 2012-10-2 10:52



    請教GBKEE版大
依照您的方式,如果網頁換成這一個 http://www.twse.com.tw/ch/trading/exchange/BWIBBU/BWIBBU.php
要如何修改呢

Option Explicit
Private Sub 大盤成交資訊()
    Dim xlTheYear As String, xlTheMonth As String, xlTheFile As String
    Dim Sh As Worksheet
    xlTheYear = Format(Range("C1"), "0000")  '修改字串格式
    xlTheMonth = Format(Range("C2"), "00")   '修改字串格式
    Set Sh = ThisWorkbook.Sheets.Add         '新增工作表
    Sh.Name = xlTheYear & "_" & xlTheMonth   '新增工作表命名
    xlTheFile = "http://www.twse.com.tw/ch/trading/exchange/FMTQIK/FMTQIK2.php?STK_NO=&myear=" & xlTheYear & "&mmon=" & xlTheMonth & "&type=csv"
    With Workbooks.Open(xlTheFile)
        .Sheets(1).UsedRange.Copy Sh.[a1]
        .Close 0
    End With
    Sh.Cells.EntireColumn.AutoFit            '調整欄寬
    Sh.Columns("A:A").ColumnWidth = 28.56
End Sub
作者: GBKEE    時間: 2013-9-19 19:42

回復 71# pupai
'http://www.twse.com.tw/ch/trading/exchange/BWIBBU/BWIBBU.php 這網址可下載檔案但不是csv檔,你可以試下載看看
你的網址少了 STK_NO (股票代號)
  1. xlTheFile = "http://www.twse.com.tw/ch/trading/exchange/FMTQIK/FMTQIK2.php?STK_NO=" & Stk_No & "&myear=" & xlTheYear & "&mmon=" & xlTheMonth & "&type=csv"
  2.     xlTheFile = "http://www.twse.com.tw/ch/trading/exchange/BWIBBU/BWIBBU.php?STK_NO=" & Stk_No & "&myear=" & xlTheYear & "&mmon=" & xlTheMonth
複製代碼
作者: pupai    時間: 2013-9-19 20:27

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

本帖最後由 GBKEE 於 2013-9-19 20:58 編輯

回復 73# pupai
試試看
  1. Option Explicit
  2. Private Sub 大盤成交資訊()
  3.     Dim xlTheYear As String, xlTheMonth As String, STK_NO As String, xlTheFile As String, AR
  4.     Dim Sh As Worksheet
  5.     xlTheYear = Format(Range("C1"), "0000")  '修改字串格式
  6.     xlTheMonth = Format(Range("C2"), "00")   '修改字串格式
  7.     STK_NO = Format(Range("C3"), "0000")  '修改字串格式
  8.     Set Sh = ThisWorkbook.Sheets.Add         '新增工作表
  9.     Sh.Name = xlTheYear & "_" & xlTheMonth   '新增工作表命名
  10.     '******http://www.twse.com.tw/ch/trading/exchange/FMTQIK/FMTQIK2.php*****
  11.     'xlTheFile = "http://www.twse.com.tw/ch/trading/exchange/FMTQIK/FMTQIK2.php?STK_NO=" & STK_NO & "&myear=" & xlTheYear & "&mmon=" & xlTheMonth & "&type=csv"
  12.    
  13.      '******http://www.twse.com.tw/ch/trading/exchange/BWIBBU/BWIBBU.php*****
  14.      xlTheFile = "http://www.twse.com.tw/ch/trading/exchange/BWIBBU/BWIBBU.php?STK_NO=" & STK_NO & "&myear=" & xlTheYear & "&mmon=" & xlTheMonth
  15.     '**************************************************************
  16.     With Workbooks.Open(xlTheFile)
  17.         If InStr(xlTheFile, "BWIBBU") Then
  18.             AR = .Sheets(1).Range("b446").CurrentRegion 'http://www.twse.com.tw/ch/trading/exchange/BWIBBU/BWIBBU.php
  19.         Else
  20.             .Sheets(1).UsedRange.Copy Sh.[A1]
  21.          End If
  22.           .Close 0

  24.     End With
  25.     With Sh
  26.         If InStr(xlTheFile, "BWIBBU") Then .Range("A1").Resize(UBound(AR, 1), UBound(AR, 2)) = AR
  27.         .Cells.EntireColumn.AutoFit            '調整欄寬
  28.         .Columns("A:A").ColumnWidth = 28.56
  29.     End With
  30. End Sub
複製代碼
作者: pupai    時間: 2013-9-19 21:12

回復 74# GBKEE

G大
    可以了
改天再跟你請教
謝謝
作者: rinkenny    時間: 2015-11-16 22:28

G大,我是VBA新手,可以請教,如果查詢大盤,按了下載後會貼在原本的工作表內,如果是想貼在原本已經存在的工作表呢?比如該工作表名稱是"歷史資料",程式碼又該怎麼修改!謝謝!
作者: GBKEE    時間: 2015-11-17 07:42

回復 76# rinkenny
試試看
  1. Option Explicit
  2. Private Sub 大盤成交資訊()
  3.     Dim xlTheYear As String, xlTheMonth As String, STK_NO As String, xlTheFile As String,  Sh As Worksheet
  4.     With Sheets("Sheet1")
  5.         xlTheYear = Format(.Range("C1"), "0000")  '修改字串格式
  6.         xlTheMonth = Format(.Range("C2"), "00")   '修改字串格式
  7.         STK_NO = Format(.Range("C3"), "0000")  '修改字串格式
  8.     End With
  9.     ''''''''''''''''''''''''''''''''''''''''''''''''''''''
  10.     Set Sh = Workbooks("你指定的活頁簿").Sheets("歷史資料")
  11.     ''''''''''''''''''''''''''''''''''''''''''''''''''''''
  12.     '******http://www.twse.com.tw/ch/trading/exchange/FMTQIK/FMTQIK2.php*****
  13.     xlTheFile = "http://www.twse.com.tw/ch/trading/exchange/FMTQIK/FMTQIK2.php?STK_NO=" & STK_NO & "&myear=" & xlTheYear & "&mmon=" & xlTheMonth & "&type=csv"
  14.         With Workbooks.Open(xlTheFile)
  15.         .Sheets(1).UsedRange.Copy Sh.Range("A" & Rows.Count).End(xlUp).Offset(1) '接著A欄 複製下去
  16.         .Close 0
  17.     End With
  18. End Sub
複製代碼
作者: rinkenny    時間: 2015-11-17 18:42

謝謝神人GB大,原來如此,感激GB大的分享
作者: even182    時間: 2015-12-17 07:52

太棒了
非常感謝GBKEE大大的熱心分享
作者: bill740615    時間: 2016-3-30 22:23

謝謝大大的分享，受益良多
作者: narusawa    時間: 2016-4-19 10:22

感謝大大分享
剛好非常需要.謝謝:)
作者: wufonna    時間: 2019-1-14 13:32

回復 5# GBKEE
請教 版大 原始的網頁不見了，可改那一個網址，謝謝



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