返回列表 上一主題 發帖

交易明細下載

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 2012-8-1 13:35 | 顯示全部帖子
回復 6# mannyhsu
  1. Option Explicit
  2. Sub 個股交易明細下載()
  3.     Dim 股票代號 As String, 日期 As Variant, N As Name, i As Integer, T As Date, A
  4.     Do While Not IsDate(日期)
  5.         日期 = InputBox("輸入查詢日期", "日期", Date)
  6.         If 日期 = "" Then End
  7.     Loop
  8.     Do While 股票代號 = ""
  9.         股票代號 = InputBox("股票代號", "輸入查詢之股票代號", "1101")
  10.         If 日期 = "" Then End
  11.     Loop
  12.     日期 = Format(日期, "yyyymmdd")
  13.     T = Time
  14.     With ActiveSheet
  15.         .Cells.Clear
  16.         DoEvents
  17.         Application.ScreenUpdating = False
  18.         Application.StatusBar = False
  19.         With .QueryTables.Add(Connection:="URL;http://bsr.twse.com.tw/bshtm/bsContent.aspx?strDate=" & 日期 & "&StartNumber=" & 股票代號 & "&FocusIndex=1", Destination:=Range("A1"))
  20.             .BackgroundQuery = True
  21.              .WebTables = "6,7"
  22.             .Refresh BackgroundQuery:=False
  23.              .ResultRange(1).End(xlDown).Offset(2).CurrentRegion.Cut .ResultRange(1).End(xlToRight).Offset(, 1)
  24.             If Application.CountA(.ResultRange) = 0 Then
  25.                 MsgBox Format(日期, "0000/00/00") & " 休市!!!  或  股票代號:" & 股票代號 & " 錯誤 !!!"
  26.                 [A1].Select
  27.                 End
  28.             End If
  29.             ActiveSheet.Names(.Name).Delete
  30.         End With
  31.         i = 2
  32.         Do
  33.             .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Select
  34.             With .QueryTables.Add(Connection:="URL;http://bsr.twse.com.tw/bshtm/bsContent.aspx?strDate=" & 日期 & "&StartNumber=" & 股票代號 & "&FocusIndex=" & i, Destination:=Selection)
  35.                 .BackgroundQuery = True
  36.                 .WebTables = "6,7"
  37.                 On Error Resume Next
  38.                 Do
  39.                      Err.Clear
  40.                 .Refresh BackgroundQuery:=False
  41.                 Loop Until Err.Number = 0
  42.                 On Error GoTo 0
  43.                 If Application.CountA(.ResultRange) = 0 Then GoTo OUT
  44.                 .ResultRange(1).End(xlDown).Offset(2).CurrentRegion.Cut .ResultRange(1).End(xlToRight).Offset(, 1)
  45.                 .ResultRange(1).EntireRow.Delete
  46.                 ActiveSheet.Names(.Name).Delete
  47.                 i = i + 1
  48.             End With
  49.         Loop
  50. OUT:
  51.         .[A1].Select
  52.         Application.ScreenUpdating = True
  53.         With .UsedRange
  54.             .WrapText = False
  55.             .Interior.ColorIndex = xlNone
  56.             .Font.Size = 12
  57.             .Columns.AutoFit
  58.             A = CreateObject("WScript.Shell").popup("共下載 " & i & " 頁費時  " & Format(Time - T, "hh:mm分SS秒"), 5, 日期 & "_" & 股票代號, 48 + 0)
  59.             Application.StatusBar = 日期 & " _ " & 股票代號 & " 共下載 " & i & "頁 費時 " & Format(Time - T, "HH:MM:SS")
  60.         End With
  61.         For Each N In .Names
  62.             N.Delete
  63.         Next
  64.      End With
  65. End Sub
複製代碼

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
2#
發表於 2012-8-1 14:44 | 顯示全部帖子
本帖最後由 GBKEE 於 2012-8-1 14:46 編輯

回復 11# lalalada
所以是只可以察看前一日 或 當日的資料
回復 12# lalalada

.ResultRange-> QueryTablet  查詢傳送來的資料範圍  
.ResultRange(1).->.ResultRange.Cells(1)
vba 的說明及範例
ResultRange 屬性 請參閱套用至範例特定傳回 Range 物件，該物件代表指定查詢表所覆蓋的工作表區域。唯讀。
範例
本範例對第一張查詢表中第一欄的資料進行加總，並在資料範圍下方顯示第一欄資料的總和。
Set c1 = Sheets("sheet1").QueryTables(1).ResultRange.Columns(1)
c1.Name = "Column1"
c1.End(xlDown).Offset(2, 0).Formula = "=sum(Column1)"

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
3#
發表於 2012-8-1 15:14 | 顯示全部帖子
回復 10# lalalada
   
  .WebTables = "4,""table2"""

修改9#如下
  1. Option Explicit
  2. Sub 個股交易明細下載()
  3.     Dim 股票代號 As String, N As Name, i As Integer, T As Date, A
  4.     Do While 股票代號 = ""
  5.         股票代號 = InputBox("股票代號", "輸入查詢之股票代號", "1101")
  6.         If 股票代號 = "" Then End
  7.     Loop
  8.     T = Time
  9.     With ActiveSheet
  10.         .Cells.Clear
  11.         DoEvents
  12.         Application.ScreenUpdating = False
  13.         Application.StatusBar = False
  14.         With .QueryTables.Add(Connection:="URL;http://bsr.twse.com.tw/bshtm/bsContent.aspx?StartNumber=" & 股票代號 & "&FocusIndex=1", Destination:=Range("A1"))
  15.             .WebFormatting = xlWebFormattingNone
  16.             .WebTables = "4,""table2"""
  17.             .Refresh BackgroundQuery:=False
  18.             If Application.CountA(.ResultRange) = 0 Then
  19.                 MsgBox "股票代號:" & 股票代號 & " 錯誤 !!!"
  20.                 [a1].Select
  21.                 End
  22.             End If
  23.             ActiveSheet.Names(.Name).Delete
  24.         End With
  25.         i = 2
  26.         Do
  27.             .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Select
  28.              With .QueryTables.Add(Connection:="URL;http://bsr.twse.com.tw/bshtm/bsContent.aspx?StartNumber=" & 股票代號 & "&FocusIndex=" & i, Destination:=Selection)
  29.                 .WebFormatting = xlWebFormattingNone
  30.                 .WebTables = "table2"
  31.                 On Error Resume Next
  32.                 Do
  33.                      Err.Clear
  34.                     .Refresh BackgroundQuery:=False
  35.                 Loop Until Err.Number = 0
  36.                 On Error GoTo 0
  37.                 If Application.CountA(.ResultRange) = 0 Then GoTo OUT
  38.                 .ResultRange(1).EntireRow.Delete
  39.                 ActiveSheet.Names(.Name).Delete
  40.                 i = i + 1
  41.             End With
  42.         Loop
  43. OUT:
  44.         .[a1].Select
  45.         Application.ScreenUpdating = True
  46.         .Columns.AutoFit
  47.         A = CreateObject("WScript.Shell").popup("共下載 " & i & " 頁費時  " & Format(Time - T, "hh:mm分SS秒"), 5, "_" & 股票代號, 48 + 0)
  48.         Application.StatusBar = "股票代號 [" & 股票代號 & "] 共下載 " & i & "頁 費時 " & Format(Time - T, "HH:MM:SS")
  49.         For Each N In .Names
  50.             N.Delete
  51.         Next
  52.      End With
  53. End Sub
複製代碼

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
4#
發表於 2012-8-9 08:11 | 顯示全部帖子
回復 23# tsuneng
並非一程式可無敵的
請上傳: 上櫃成交資料網頁
我來試試看

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
5#
發表於 2012-8-10 17:05 | 顯示全部帖子
回復 26# tsuneng
讓你失望了, 試了一天 仍是失敗 對網頁語言不熟 無法下載 這網址所有的資料
http://www.gretai.org.tw/ch/stock/aftertrading/broker_trading/brokerBS.php?  嚐試用 IE 下載Tables 的內容 但還是失敗
如http://forum.twbts.com/viewthread.php?tid=7395&page=1&extra=#pid42189 的5# 附檔
這http://www.gretai.org.tw/ch/stock/aftertrading/broker_trading/download_ALLCSV.php?'可下載全部CSV: 但對網頁架構不熟,寫不出它的參數
望知悉者相助
用 EXCEL  WEB的查詢也有所限制,只可查看第一頁的資料,
  1. Option Explicit
  2. Sub Ex()
  3.     With ActiveSheet.QueryTables.Add("URL;http://www.gretai.org.tw/ch/stock/aftertrading/broker_trading/brokerBS.php?stk_code=6121", ActiveSheet.[A1])
  4.         .WebSelectionType = xlSpecifiedTables
  5.         .WebFormatting = xlWebFormattingNone
  6.         .WebTables = "11,13,14"
  7.         .Refresh BackgroundQuery:=False
  8.     End With
  9. End Sub
複製代碼

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
6#
發表於 2012-8-10 21:19 | 顯示全部帖子
本帖最後由 GBKEE 於 2012-8-11 06:54 編輯

回復 33# diabo
感謝相助 成功!
  1. Option Explicit
  2. Private Sub 下載htm()
  3.     Dim xml As Object     '用來取得網頁資料
  4.     Dim stream            'As ADODB.stream   '用來儲存二進位檔案
  5.     Dim URL As String     '目的網址
  6.     Dim thePOSTdata       '參數
  7.     Set xml = CreateObject("Microsoft.XMLHTTP")
  8.     Set stream = CreateObject("ADODB.stream")
  9.     URL = "http://www.gretai.org.tw/ch/stock/aftertrading/broker_trading/download_ALLCSV.php"
  10.     thePOSTdata = "curstk=3527&stk_date=1010810"
  11.         xml.Open "POST", URL, 0
  12.         xml.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
  13.         xml.send thePOSTdata
  14.     With stream
  15.         .Open
  16.         .Type = 1
  17.         .write xml.ResponseBody
  18.         If Dir("D:\3527.CSV") <> "" Then Kill "D:\3527.CSV"
  19.         .SaveToFile ("D:\3527.CSV")                              
  20.         .Close
  21.     End With
  22. Set xml = Nothing
  23. Set stream = Nothing
  24. End Sub
複製代碼

TOP

        靜思自在 : 不要隨心所欲，要隨心教育自己。
返回列表 上一主題