Board logo

標題: [發問] 有辦法將每日資料會成一份嘛 [打印本頁]
作者: pupai    時間: 2013-9-20 09:47     標題: 有辦法將每日資料會成一份嘛

您好
我希望可以把每日的資料彙整成一份
請大家幫嘛指導
謝謝!!
  1. Sub GetData()

  3.     Dim DataSheet As Worksheet
  4.     Dim EndDate As Date
  5.     Dim StartDate As Date
  6.     Dim Symbol As String
  7.     Dim qurl As String
  8.     Dim nQuery As Name
  9.    
  10.     Application.ScreenUpdating = False
  11.     Application.DisplayAlerts = False
  12.     Application.Calculation = xlCalculationManual
  13.    
  14.     Set DataSheet = ActiveSheet
  15.   
  16.         StartDate = DataSheet.Range("B1").Value
  17.         EndDate = DataSheet.Range("B2").Value
  18.         Symbol = DataSheet.Range("B3").Value
  19.         Range("C7").CurrentRegion.ClearContents
  20.         
  21.         qurl = "http://www.twse.com.tw/ch/trading/exchange/BWIBBU/BWIBBU.php?" & Symbol
  22.         qurl = qurl & "&a=" & Month(StartDate) - 1 & "&b=" & Day(StartDate) & _
  23.             "&c=" & Year(StartDate) & "&d=" & Month(EndDate) - 1 & "&e=" & _
  24.             Day(EndDate) & "&f=" & Year(EndDate) & "&g=" & Range("E3") & "&q=q&y=0&z=" & _
  25.             Symbol & "&x=.csv"
  26.                   
  27. QueryQuote:
  28.             With ActiveSheet.QueryTables.Add(Connection:="URL;" & qurl, Destination:=DataSheet.Range("C7"))
  29.                  .AdjustColumnWidth = False
  30.                 .BackgroundQuery = True
  31.                 .TablesOnlyFromHTML = False
  32.                 .Refresh BackgroundQuery:=False
  33.                 .SaveData = True
  34.                
  35.             End With
  36.             
  37.             Range("C7").CurrentRegion.TextToColumns Destination:=Range("C7"), DataType:=xlDelimited, _
  38.                 TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
  39.                 Semicolon:=False, Comma:=True, Space:=False, other:=False
  40.             
  41.             Range(Range("C7"), Range("C7").End(xlDown)).NumberFormat = "yyyy/mm/dd"
  42.             Range(Range("D7"), Range("G7").End(xlDown)).NumberFormat = "0.00"

  44. End Sub
複製代碼
作者: GBKEE    時間: 2013-9-20 11:17

本帖最後由 GBKEE 於 2013-9-20 11:47 編輯

回復 1# pupai
如何每日資料匯成一份??
  1. 你的網址少了 STK_NO (股票代號)
  2. 'qurl = qurl & "&a=" & Month(StartDate) - 1 & "&b=" & Day(StartDate) & _
  3.             "&c=" & Year(StartDate) & "&d=" & Month(EndDate) - 1 & "&e=" & _
  4.             Day(EndDate) & "&f=" & Year(EndDate) & "&g=" & Range("E3") & "&q=q&y=0&z=" & _
  5.             Symbol & "&x=.csv"
  6.             '*** 上面的網址qurl 為何要 a= b= c= d= e= 這些  ******
  7.              qurl = "http://www.twse.com.tw/ch/trading/exchange/BWIBBU/BWIBBU.php?myear=2013&mmon=9&STK_NO=2371"         

  9.             
複製代碼
作者: pupai    時間: 2013-9-20 12:02

回復 2# GBKEE


    G大還是不行
  1. Sub GetData()

  3.     Dim DataSheet As Worksheet
  4.     Dim EndDate As Date
  5.     Dim StartDate As Date
  6.     Dim Symbol As String
  7.     Dim qurl As String
  8.     Dim nQuery As Name
  9.    
  10.     Application.ScreenUpdating = False
  11.     Application.DisplayAlerts = False
  12.     Application.Calculation = xlCalculationManual
  13.    
  14.     Set DataSheet = ActiveSheet
  15.   
  16.         StartDate = DataSheet.Range("B1").Value
  17.         EndDate = DataSheet.Range("B2").Value
  18.         Symbol = DataSheet.Range("B3").Value
  19.         Range("C7").CurrentRegion.ClearContents
  20.         
  21.         qurl = qurl & "&a=" & Month(StartDate) - 1 & "&b=" & Day(StartDate) & _
  22.             "&c=" & Year(StartDate) & "&d=" & Month(EndDate) - 1 & "&e=" & _
  23.             Day(EndDate) & "&f=" & Year(EndDate) & "&g=" & Range("E3") & "&q=q&y=0&z=" & _
  24.             Symbol & "&x=.csv"
  25.             '*** 上面的網址qurl 為何要 a= b= c= d= e= 這些  ******
  26.              qurl = "http://www.twse.com.tw/ch/trading/exchange/BWIBBU/BWIBBU.php?myear=2013&mmon=9&STK_NO=2371"   
  27.                   
  28. QueryQuote:
  29.             With ActiveSheet.QueryTables.Add(Connection:="URL;" & qurl, Destination:=DataSheet.Range("C7"))
  30.                  .AdjustColumnWidth = False
  31.                 .BackgroundQuery = True
  32.                 .TablesOnlyFromHTML = False
  33.                 .Refresh BackgroundQuery:=False
  34.                 .SaveData = True
  35.                
  36.             End With
  37.             
  38.             Range("C7").CurrentRegion.TextToColumns Destination:=Range("C7"), DataType:=xlDelimited, _
  39.                 TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
  40.                 Semicolon:=False, Comma:=True, Space:=False, other:=False
  41.             
  42.             Range(Range("C7"), Range("C7").End(xlDown)).NumberFormat = "yyyy/mm/dd"
  43.             Range(Range("D7"), Range("G7").End(xlDown)).NumberFormat = "0.00"

  45. End Sub
複製代碼
作者: GBKEE    時間: 2013-9-20 12:25

本帖最後由 GBKEE 於 2013-9-20 12:27 編輯

回復 3# pupai
請詳看圖示的錯誤信息,去看看儲存格的範圍,不知你要如何每日資料匯成一份??
作者: pupai    時間: 2013-9-20 12:37

回復 4# GBKEE


    不懂
可否詳細說明
謝謝!!
作者: pupai    時間: 2013-9-20 13:30

回復 4# GBKEE

G大
    那請問有辦法把http://www.twse.com.tw/ch/trading/exchange/BWIBBU/BWIBBU.php的資料
用VB的方式作成可以查詢股票代碼且有連續時間的一份資料(比方:2009/01/01到2013/09/18 )
謝謝
作者: GBKEE    時間: 2013-9-20 16:20

回復 6# pupai
  1. Option Explicit
  2. Sub GetData()
  3.     Dim DataSheet As Worksheet, Sh As Worksheet, Msg As Boolean
  4.     Dim EndDate As Date, StartDate As Date, i As Integer, AR, xR As Long
  5.     Dim Symbol As String, Qur As String
  6.     Set DataSheet = Sheets("Sheet1")
  7.     With DataSheet
  8.         StartDate = .[b1]
  9.         EndDate = .[b2]
  10.         Symbol = .[b3]
  11.         .Range("D1").CurrentRegion = ""
  12.     End With
  13.     '本資料自民國94年09月01日開始提供 *** 除錯  ***
  14.     If StartDate < #9/1/2005# Or EndDate < #9/1/2005# Or Len(Symbol) <= 3 Or StartDate > EndDate Or EndDate > Date Then
  15.         MsgBox "數據有誤" & IIf(StartDate < #9/1/2005#, vbLf & "StartDate :日期 小於 94年09月01日  ", "") & _
  16.         IIf(EndDate < #9/1/2005#, vbLf & "EndDate :日期 小於 94年09月01日  ", "") & _
  17.         IIf(Len(Symbol) <= 3, vbLf & "Symbol : 股票代號 ", "") & _
  18.         IIf(StartDate > EndDate, vbLf & "StartDate > EndDate", "") & _
  19.         IIf(EndDate > Date, vbLf & " EndDate >" & Date, "")
  20.         Exit Sub
  21.     End If
  22.     '*********************************************
  23.     Set Sh = Sheets.Add(Sheets(1))
  24.     DataSheet.Activate
  25.     Do While DateSerial(Year(StartDate), Month(StartDate), 1) <= EndDate
  26.         Qur = "http://www.twse.com.tw/ch/trading/exchange/BWIBBU/BWIBBU.php?myear=" & Format(StartDate, "yyyy") & "&mmon=" & Format(StartDate, "m") & "&STK_NO=" & Symbol
  27.         With Sh
  28.             If .QueryTables.Count = 0 Then
  29.                 .QueryTables.Add "URL;" & Qur, .[A1]
  30.             Else
  31.                 .QueryTables(1).Connection = "URL;" & Qur
  32.                 Msg = True
  33.             End If
  34.            With .QueryTables(1)
  35.                 .WebFormatting = xlWebFormattingNone
  36.                 .WebSelectionType = xlSpecifiedTables
  37.                 .WebDisableDateRecognition = True
  38.                 .WebTables = "8"
  39.                  .Refresh BackgroundQuery:=False
  40.                  If Application.CountA(.ResultRange) = 0 Then Msg = False
  41.                  If Msg Then
  42.                     AR = .ResultRange.Offset(2)
  43.                  Else
  44.                     AR = .ResultRange
  45.                  End If
  46.                  With DataSheet
  47.                     xR = Application.CountA(.[d:d]) + 1
  48.                     .Cells(xR, "D").Resize(UBound(AR, 1), UBound(AR, 2)) = AR
  49.                  End With
  50.            End With
  51.            End With
  52.         StartDate = DateAdd("m", 1, StartDate)
  53.     Loop
  54.     Application.DisplayAlerts = False
  55.     Sh.Delete
  56.     Application.DisplayAlerts = True
  57. End Sub
複製代碼
作者: pupai    時間: 2013-9-20 21:05

回復 7# GBKEE


請教 G大
根據上面執行後startdate與enddate好像有問題
跑不出來
結果如附件
謝謝!!
作者: GBKEE    時間: 2013-9-21 07:03

回復 8# pupai
沒有啊!
圖示為 執行 7# 程式碼 的結果


[attach]16118[/attach]
作者: pupai    時間: 2013-9-21 08:24

回復 9# GBKEE


    可以了~~感恩!!
作者: pupai    時間: 2013-9-21 14:02

回復 10# pupai


    謝謝GBKEE版主的分享
兩個問題請教
1.D欄文字轉數字
2.另外下載完後的資料，自動儲存到另一個SHEET（以股票命名）
謝謝您
作者: GBKEE    時間: 2013-9-21 14:25

回復 11# pupai
這都可以用巨集錄製試試看,練習才會進步的.
************************************
1.新增一工作表,將之命名為股票代號.         
2將下載的資料,複製到,此新工作表
*************************************
1.原程式中有新增工作表,可將之命名為股票代號.
2,將下載的資料,複製到,此新增工作表
作者: pupai    時間: 2013-9-21 15:14

回復 12# GBKEE


    GBKEE版主
我有用巨集完成(如附件)
1.D欄文字轉數字
2.下載完後的資料，自動儲存到另一個SHEET（以股票命名）
但我寫知道VBA要如何完成上面的動作
另外我有個新問題
如果我在一個代碼分頁中(A1欄輸入股票代碼1101,1102,1103,1104,1108,1109,1110,1201,1203…等等)
VBA可以產生一個迴圈一次幫我跑完這一些股票代碼的歷年資料，並再自動儲存在另一個SHEET（以股票命名）？
謝謝!!
作者: GBKEE    時間: 2013-9-21 16:28

回復 13# pupai
你說:我有用巨集完成(如附件),有嗎?哪有完成.


[attach]16122[/attach]
  1. Option Explicit
  2. Sub GetData()
  3.     Dim DataSheet As Worksheet, Sh As Worksheet, Msg As Boolean
  4.     Dim EndDate As Date, StartDate As Date, AR, xR As Long
  5.     Dim Symbol As Variant, Qur As String
  6.     Set DataSheet = Sheets("代碼")
  7.     With DataSheet
  8.         StartDate = .[C1]
  9.         EndDate = .[C2]
  10.         '本資料自民國94年09月01日開始提供 *** 除錯  ***
  11.         If StartDate < #9/1/2005# Or EndDate < #9/1/2005# Or StartDate > EndDate Or EndDate > Date Then
  12.             MsgBox "數據有誤" & IIf(StartDate < #9/1/2005#, vbLf & "StartDate :日期 小於 94年09月01日  ", "") & _
  13.             IIf(EndDate < #9/1/2005#, vbLf & "EndDate :日期 小於 94年09月01日  ", "") & _
  14.             IIf(StartDate > EndDate, vbLf & "StartDate > EndDate", "") & _
  15.             IIf(EndDate > Date, vbLf & " EndDate >" & Date, "")
  16.             Exit Sub
  17.         End If
  18.     '*********************************************
  19.         Application.DisplayAlerts = False
  20.         For Each Sh In Sheets
  21.             If Sh.Name <> DataSheet.Name Then Sh.Delete    '刪除不必要的工作
  22.         Next
  23.         For Each Symbol In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))  '股票的迴圈
  24.             Msg = False
  25.             StartDate = .[C1]                           '迴圈需重新回到原本的 StartDate日期
  26.             Set Sh = Sheets.Add(, Sheets(Sheets.Count)) '新增的工作表位於活頁簿最後面(Sheets.Count)
  27.             DataSheet.Activate
  28.             
  29.             Do While DateSerial(Year(StartDate), Month(StartDate), 1) <= EndDate
  30.                 Qur = "http://www.twse.com.tw/ch/trading/exchange/BWIBBU/BWIBBU.php?myear=" & Format(StartDate, "yyyy") & "&mmon=" & Format(StartDate, "m") & "&STK_NO=" & Symbol
  31.                 With Sh       '新增的工作表
  32.                     If .QueryTables.Count = 0 Then                      'Web查詢
  33.                         .QueryTables.Add "URL;" & Qur, .[M1]            'Web查詢資料在M欄
  34.                     Else
  35.                         .QueryTables(1).Connection = "URL;" & Qur
  36.                         Msg = True
  37.                     End If
  38.                     With .QueryTables(1)
  39.                         .WebFormatting = xlWebFormattingNone
  40.                         .WebSelectionType = xlSpecifiedTables
  41.                         .WebDisableDateRecognition = True
  42.                         .WebTables = "8"
  43.                         .Refresh BackgroundQuery:=False
  44.                         If Application.CountA(.ResultRange) = 0 Then Msg = False
  45.                         If Msg Then
  46.                             AR = .ResultRange.Offset(2)
  47.                         Else
  48.                             AR = .ResultRange
  49.                         End If
  50.                         xR = Application.CountA(.Parent.[d:d]) + 1                         '.Parent :Web查詢的父層
  51.                         .Parent.Cells(xR, "A").Resize(UBound(AR, 1), UBound(AR, 2)) = AR   '資料複製到 新增工作表的A欄
  52.                     End With
  53.                 End With
  54.                 StartDate = DateAdd("m", 1, StartDate)   '日期 + 1個月
  55.             Loop
  56.             With Sh
  57.                 .Name = Symbol                                 '以股票命名
  58.                 .QueryTables(1).ResultRange = ""               '清除Web查詢的資料
  59.                  .Names(.QueryTables(1).Name).Delete           'Web查詢的名稱
  60.             End With
  61.         Next
  62.     End With
  63.     Application.DisplayAlerts = True
  64. End Sub
複製代碼
作者: pupai    時間: 2013-9-21 20:41

回復 14# GBKEE


    G大您好
再次感謝您的熱心的指導
我研究看看
謝謝...
作者: pupai    時間: 2013-9-21 21:00

  1. 程式我大概說明一下

  3. Option Explicit
  4. Sub GetData()
  5.     Dim DataSheet As Worksheet, Sh As Worksheet, Msg As Boolean               '定義變數
  6.     Dim EndDate As Date, StartDate As Date, i As Integer, AR, xR As Long    '定義變數
  7.     Dim Symbol As String, Qur As String                                                            '定義變數
  8.     Set DataSheet = Sheets("Sheet1")                                                                   '設定工作表名稱
  9.     With DataSheet
  10.         StartDate = .[b1]                                                                                          '將B1欄位值讀到變數StartDate中
  11.         EndDate = .[b2]                                                                                           '將B2欄位值讀到變數EndDate中
  12.         Symbol = .[b3]                                                                                             '將B3欄位值讀到變數Symbol中
  13.         .Range("D1").CurrentRegion = ""                                                               '設定D1欄位值
  14.     End With
  15.     '本資料自民國94年09月01日開始提供 *** 除錯  ***                                '以下以94/09/01為界限,判讀輸入值是否有錯
  16.     If StartDate < #9/1/2005# Or EndDate < #9/1/2005# Or Len(Symbol) <= 3 Or StartDate > EndDate Or EndDate > Date Then
  17.         MsgBox "數據有誤" & IIf(StartDate < #9/1/2005#, vbLf & "StartDate :日期 小於 94年09月01日  ", "") & _
  18.         IIf(EndDate < #9/1/2005#, vbLf & "EndDate :日期 小於 94年09月01日  ", "") & _
  19.         IIf(Len(Symbol) <= 3, vbLf & "Symbol : 股票代號 ", "") & _
  20.         IIf(StartDate > EndDate, vbLf & "StartDate > EndDate", "") & _
  21.         IIf(EndDate > Date, vbLf & " EndDate >" & Date, "")
  22.         Exit Sub
  23.     End If
  24.     '*********************************************
  25.     Set Sh = Sheets.Add(Sheets(1))
  26.     DataSheet.Activate
  27.     Do While DateSerial(Year(StartDate), Month(StartDate), 1) <= EndDate   ' DO到LOOP中的程式為以輸入值去抓取網頁的資料
  28.         Qur = "http://www.twse.com.tw/ch/trading/exchange/BWIBBU/BWIBBU.php?myear=" & Format(StartDate, "yyyy") & "&mmon=" & Format(StartDate, "m") & "&STK_NO=" & Symbol
  29.         With Sh
  30.             If .QueryTables.Count = 0 Then
  31.                 .QueryTables.Add "URL;" & Qur, .[A1]
  32.             Else
  33.                 .QueryTables(1).Connection = "URL;" & Qur
  34.                 Msg = True
  35.             End If
  36.            With .QueryTables(1)
  37.                 .WebFormatting = xlWebFormattingNone
  38.                 .WebSelectionType = xlSpecifiedTables
  39.                 .WebDisableDateRecognition = True
  40.                 .WebTables = "8"
  41.                  .Refresh BackgroundQuery:=False
  42.                  If Application.CountA(.ResultRange) = 0 Then Msg = False
  43.                  If Msg Then
  44.                     AR = .ResultRange.Offset(2)
  45.                  Else
  46.                     AR = .ResultRange
  47.                  End If
  48.                  With DataSheet
  49.                     xR = Application.CountA(.[d:d]) + 1
  50.                     .Cells(xR, "D").Resize(UBound(AR, 1), UBound(AR, 2)) = AR
  51.                  End With
  52.            End With
  53.            End With
  54.         StartDate = DateAdd("m", 1, StartDate)                            '這行就是能抓跨月的計算式,抓完第一個月後,變數StartDate的月份+1
  55.     Loop
  56.     Application.DisplayAlerts = False
  57.     Sh.Delete
  58.     Application.DisplayAlerts = True
  59. End Sub
複製代碼
分享G大的程式碼
作者: GBKEE    時間: 2013-9-21 21:13

回復 16# pupai
你還是沒搞清楚CurrentRegion是什麼,須多看vba的說明.
  1.   .Range("D1").CurrentRegion = ""                                                               '設定D1欄位值
複製代碼
作者: pupai    時間: 2013-9-22 12:04

回復 17# GBKEE


    呵呵....苦笑 我再努力.   受教了
作者: pupai    時間: 2013-10-23 11:29     標題: 如何避免當查詢日期 小於 資料日期時 程式中斷

您好
代碼1773的歷史資料從2009/2/27開始有資料
假設我在StartDate打入2006/1/1
當程式執行到1773就會中斷
請問要如何修改
謝謝!!
作者: GBKEE    時間: 2013-10-23 16:17

本帖最後由 GBKEE 於 2013-10-23 16:18 編輯

回復 19# pupai
  1. Option Explicit
  2. Sub GetData()
  3.     Dim DataSheet As Worksheet, Sh As Worksheet
  4.     Dim EndDate As Date, StartDate As Date, AR, xR As Long
  5.     Dim Symbol As Variant, Qur As String
  6.     Set DataSheet = Sheets("代碼")
  7.     With DataSheet
  8.         StartDate = .[C1]
  9.         EndDate = .[C2]
  10.         '本資料自民國94年09月01日開始提供 *** 除錯  ***
  11.         If StartDate < #9/1/2005# Or EndDate < #9/1/2005# Or StartDate > EndDate Or EndDate > Date Then
  12.             MsgBox "數據有誤" & IIf(StartDate < #9/1/2005#, vbLf & "StartDate :日期 小於 94年09月01日  ", "") & _
  13.             IIf(EndDate < #9/1/2005#, vbLf & "EndDate :日期 小於 94年09月01日  ", "") & _
  14.             IIf(StartDate > EndDate, vbLf & "StartDate > EndDate", "") & _
  15.             IIf(EndDate > Date, vbLf & " EndDate >" & Date, "")
  16.             Exit Sub
  17.         End If
  18.     '*********************************************
  19.         Application.DisplayAlerts = False
  20.         For Each Sh In Sheets
  21.             If Sh.Name <> DataSheet.Name Then Sh.Delete    '刪除不必要的工作
  22.         Next
  23.         For Each Symbol In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))  '股票的迴圈
  24.             StartDate = .[C1]                           '迴圈需重新回到原本的 StartDate日期
  25.             Set Sh = Sheets.Add(, Sheets(Sheets.Count)) '新增的工作表位於活頁簿最後面(Sheets.Count)
  26.             DataSheet.Activate
  27.             Do While DateSerial(Year(StartDate), Month(StartDate), 1) <= EndDate
  28.                 Qur = "http://www.twse.com.tw/ch/trading/exchange/BWIBBU/BWIBBU.php?myear=" & Format(StartDate, "yyyy") & "&mmon=" & Format(StartDate, "m") & "&STK_NO=" & Symbol
  29.                 With Sh       '新增的工作表
  30.                     If .QueryTables.Count = 0 Then                      'Web查詢
  31.                         .QueryTables.Add "URL;" & Qur, .[M1]            'Web查詢資料在M欄
  32.                     Else
  33.                         .QueryTables(1).Connection = "URL;" & Qur
  34.                     End If
  35.                     With .QueryTables(1)
  36.                         .WebFormatting = xlWebFormattingNone
  37.                         .WebSelectionType = xlSpecifiedTables
  38.                         .WebDisableDateRecognition = True
  39.                         .WebTables = "7,8"
  40.                         .Refresh BackgroundQuery:=False
  41.                          If Application.CountA(.ResultRange) > 1 Then
  42.                             AR = .ResultRange.Offset(4)
  43.                             If Application.CountA(.Parent.[a:a]) = 0 Then AR = .ResultRange.Offset(3)
  44.                             xR = Application.CountA(.Parent.[a:a]) + 1                         '.Parent :Web查詢的父層
  45.                             .Parent.Cells(xR, "A").Resize(UBound(AR, 1), UBound(AR, 2)) = AR   '資料複製到 新增工作表的A欄
  46.                         End If
  47.                     End With
  48.                     
  49.                 End With

  51.                 StartDate = DateAdd("m", 1, StartDate)   '日期 + 1個月
  52.             Loop
  53.             With Sh
  54.                 .Name = Symbol                                 '以股票命名
  55.                 '------------------------
  56.                 .Activate
  57.                 .Range("E3").Select
  58.                 ActiveCell.FormulaR1C1 = _
  59.                 "=IF(ISERROR(DATEVALUE(1911+MID(RC[-4],1,FIND(""/"",RC[-4])-1) & MID(RC[-4],FIND(""/"",RC[-4]),LEN(RC[-4])))),"""",DATEVALUE(1911+MID(RC[-4],1,FIND(""/"",RC[-4])-1) & MID(RC[-4],FIND(""/"",RC[-4]),LEN(RC[-4]))))"
  60.                 .Range("E3").Select
  61.                 Selection.Copy
  62.                 .Columns("E:E").Select
  63.                 ActiveSheet.Paste
  64.                 .Columns("E:E").Select
  65.                 Selection.NumberFormatLocal = "[$-404]e/m/d;@"
  66.                 '------------------------
  67.                 .QueryTables(1).ResultRange = ""               '清除Web查詢的資料
  68.                  .Names(.QueryTables(1).Name).Delete           'Web查詢的名稱
  69.             End With
  70.         Next
  71.     End With
  72.     Application.DisplayAlerts = True
  73. End Sub
複製代碼
作者: pupai    時間: 2013-10-23 16:41

回復 20# GBKEE


    有勞G大
  感恩!!
PS:原來我可以接著問,謝謝提點
作者: pupai    時間: 2013-10-28 18:13

回復 20# GBKEE


    請問G大
我加上巨集後
結果是我要的版面沒錯
但我從Web查詢的資料卻沒有出現
請指導!!   謝謝!!
作者: pupai    時間: 2013-11-1 11:03     標題: 要如何讓Web下載的資料呈現，且同時又可以附帶有Sheet1的版面

請問
目前程式得到的結果 可以讓每個Web下載的分頁有Sheet1的版面
但是 從Web下載的資料卻沒有出現
請問要如何讓每一次Web下載的資料呈現，且同時又可以附帶有Sheet1相同的版面
謝謝!!
作者: GBKEE    時間: 2013-11-1 16:41

回復 23# pupai
應該是在這繼續發問的

附檔試試看對否
[attach]16545[/attach]
作者: pupai    時間: 2013-11-1 17:05

回復 24# GBKEE


    可以了
我先吸收一下
謝謝!!
作者: pupai    時間: 2013-11-1 17:11

  1. Option Explicit
  2. Sub GetData()
  3.     Dim DataSheet As Worksheet, Sh As Worksheet
  4.     Dim EndDate As Date, StartDate As Date, AR, xR As Long
  5.     Dim Symbol As Variant, Qur As String
  6.     Set DataSheet = Sheets("代碼")
  7.     With DataSheet
  8.         StartDate = .[C1]
  9.         EndDate = .[C2]
  10.         '本資料自民國94年09月01日開始提供 *** 除錯  ***
  11.         If StartDate < #9/1/2005# Or EndDate < #9/1/2005# Or StartDate > EndDate Or EndDate > Date Then
  12.             MsgBox "數據有誤" & IIf(StartDate < #9/1/2005#, vbLf & "StartDate :日期 小於 94年09月01日  ", "") & _
  13.             IIf(EndDate < #9/1/2005#, vbLf & "EndDate :日期 小於 94年09月01日  ", "") & _
  14.             IIf(StartDate > EndDate, vbLf & "StartDate > EndDate", "") & _
  15.             IIf(EndDate > Date, vbLf & " EndDate >" & Date, "")
  16.             Exit Sub
  17.         End If
  18.     '*********************************************
  19.         Application.DisplayAlerts = False
  20.         For Each Sh In Sheets
  21.             If Sh.Name <> DataSheet.Name Then Sh.Delete    '刪除不必要的工作
  22.         Next
  23.         For Each Symbol In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))  '股票的迴圈
  24.             StartDate = .[C1]                           '迴圈需重新回到原本的 StartDate日期
  25.             Set Sh = Sheets.Add(, Sheets(Sheets.Count)) '新增的工作表位於活頁簿最後面(Sheets.Count)
  26.             DataSheet.Activate
  27.             Do While DateSerial(Year(StartDate), Month(StartDate), 1) <= EndDate
  28.                 Qur = "http://www.twse.com.tw/ch/trading/exchange/BWIBBU/BWIBBU.php?myear=" & Format(StartDate, "yyyy") & "&mmon=" & Format(StartDate, "m") & "&STK_NO=" & Symbol
  29.                 With Sh       '新增的工作表
  30.                     If .QueryTables.Count = 0 Then                      'Web查詢
  31.                         .QueryTables.Add "URL;" & Qur, .[M1]            'Web查詢資料在M欄
  32.                     Else
  33.                         .QueryTables(1).Connection = "URL;" & Qur
  34.                     End If
  35.                     With .QueryTables(1)
  36.                         .WebFormatting = xlWebFormattingNone
  37.                         .WebSelectionType = xlSpecifiedTables
  38.                         .WebDisableDateRecognition = True
  39.                         .WebTables = "7,8"
  40.                         .Refresh BackgroundQuery:=False
  41.                          If Application.CountA(.ResultRange) > 1 Then
  42.                             AR = .ResultRange.Offset(4)
  43.                             If Application.CountA(.Parent.[a:a]) = 0 Then AR = .ResultRange.Offset(3)
  44.                             xR = Application.CountA(.Parent.[a:a]) + 1                         '.Parent :Web查詢的父層
  45.                             .Parent.Cells(xR, "A").Resize(UBound(AR, 1), UBound(AR, 2)) = AR   '資料複製到 新增工作表的A欄
  46.                         End If
  47.                     End With
  48.                     
  49.                 End With

  51.                 StartDate = DateAdd("m", 1, StartDate)   '日期 + 1個月
  52.             Loop
  53.             With Sh
  54.                 .Name = Symbol                                 '以股票命名
  55.                 '------------------------
  56.                 .Activate
  57.                 .Range("A:A").Select
  58.                 Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
  59.                 TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
  60.                 Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
  61.                 :=Array(1, 10), TrailingMinusNumbers:=True

  63.    
  64.                 .Range("f1").Select
  65.                 Application.CutCopyMode = False
  66.                 ActiveSheet.Paste
  67.             
  68.                .Range("F19") = Symbol
  69.                
  70.                .Range("G19:L19").Select
  71.                
  72.                 '------------------------
  73.                 .QueryTables(1).ResultRange = ""               '清除Web查詢的資料
  74.                  .Names(.QueryTables(1).Name).Delete           'Web查詢的名稱
  75.             End With
  76.         Next
  77.     End With
  78.     Application.DisplayAlerts = True
  79. End Sub
複製代碼
先跟各位報告還是以G大的版本比較好
這是我先前修改的程式 不好用
原因
  .Range("A:A").Select
                Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
                Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
                :=Array(1, 10), TrailingMinusNumbers:=True
這一段如果遇到沒有資料 程式會停擺

另外這一段
.Range("f1").Select
                Application.CutCopyMode = False
                ActiveSheet.Paste
雖然可以複製格式 但是陣列公式沒法啟動

以上跟各位交流
再次感謝G大的用心 謝謝



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