返回列表 上一主題 發帖

交易明細下載

請問各位大大:
為什麼我貼上以後,它一直說找不到巨集?
有沒有檔案可以讓我看一下...
感謝 !
shall

TOP

回復 13# GBKEE
回復 14# HSIEN6001

     感謝兩位的說明!!

TOP

回復 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

回復 10# lalalada

參考!參考!~~有誤請糾正我!

我的理解是
.RefreshStyle = xlOverwriteCells        '= xlOverwriteCells '覆蓋原欄位   = xlInsertDeleteCells '插入新資料,原資料右移


所以抓完全頁面之後的應用
Option Explicit
Sub Ex()
    Dim QueryTable_Name As String
    With ActiveSheet
        With .QueryTables.Add(Connection:="URL;http://******", Destination:=Range("A1"))
            QueryTable_Name = .Name
            .RefreshStyle = xlOverwriteCells        '= xlOverwriteCells '覆蓋原欄位   = xlInsertDeleteCells '插入新資料,原資料右移
            .Refresh BackgroundQuery:=False
        End With
        .Names(QueryTable_Name).Delete   '刪除:查詢在工作表所定義的範圍名稱
    End With

'這裡另外剪貼出去,讓檔案各自獨立
Columns("資料範圍").Select
Selection.Cut      '剪下資料的範圍
Workbooks.Add   '新增資料表
Range("A1").Paste
Application.CutCopyMode = False
ActiveWorkbook.SaveAs

End Sub

TOP

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

實際上不需要輸入日期引數就可以載入網頁~

另外想請教
.ResultRange(1).End(xlDown).Offset(2).CurrentRegion.Cut .ResultRange(1).End(xlToRight).Offset(, 1)
這兩句是什麼意思?

TOP

回復  GBKEE

yap 就是這個
另外提供一小段程式碼
可以免去手動輸入日期
反正他也只有一天的資料可以 ...
lalalada 發表於 2012-8-1 13:56



超過三分鐘不能編輯...
我發現日期隨便打抓到的東西都一樣!
所以也不需要特別指定了@@

TOP

回復 9# GBKEE

yap 就是這個
另外提供一小段程式碼
可以免去手動輸入日期
反正他也只有一天的資料可以下載
Sheets.Add
With ActiveSheet.QueryTables.Add(Connection:="URL;http://bsr.twse.com.tw/bshtm/bsContent.aspx?StartNumber=1101&FocusIndex=All_1", Destination:=Range("A1"))
        .PreserveFormatting = True
        .RefreshStyle = xlInsertDeleteCells
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "4,""table2"""
        .Refresh BackgroundQuery:=False
        End With
dataDate = Format(Cells(1, 2), "yyyymmdd")

TOP

回復 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

本帖最後由 lalalada 於 2012-8-1 11:00 編輯

喔喔 不好意思
之前我以為成功了 結果跑完之後發現資料是錯的...
這是我之前寫的:
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
    With WinHttpReq
    .Open "POST", URL, False
    .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    .Send (varBody)
           Set oStream = CreateObject("ADODB.Stream")
           oStream.Open
           oStream.Type = 1
           oStream.Write WinHttpReq.ResponseBody
           oStream.SaveToFile ("C:\AA\temp\" & CStr(code) & ".csv")
           oStream.Close
    End With
Application.Workbooks.Open ("C:\AA\temp\" & CStr(code) & ".csv")
Cells.Find(what:="sp_list").Activate
Page = Left(ActiveCell, a, b)
就如之前所說 是將網頁原始檔抓下來再讀取
發現後就開始修改 等真的弄好再po完整版
這幾天只能繼續用G版大之前寫的土法煉鋼抓有興趣的股票 囧
目前可能要請教用PYTHON的那位囉 看起來好像可以抓成csv檔(?)
不過他似乎專注於開新版而沒有要PO程式碼的意思
所以最近也要開始學了~

TOP

        靜思自在 : 手心向下是助人,手心向上是求人;助人快樂,求人痛苦。
返回列表 上一主題