123
返回列表 上一主題 發帖

[發問] 有辦法將每日資料會成一份嘛

pupai

帖子
184 
主題
45 
精華
0 
積分
407 
點名
0  
作業系統
WIN 7 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
註冊時間
2010-8-19 
最後登錄
2024-11-1 

論壇贊助勳章
1# 跳轉到 » 正序看帖
打印
tT
發表於 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
複製代碼

test.rar (30.19 KB)

收藏 分享

pupai

帖子
184 
主題
45 
精華
0 
積分
407 
點名
0  
作業系統
WIN 7 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
註冊時間
2010-8-19 
最後登錄
2024-11-1 

論壇贊助勳章
26#
發表於 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大的用心 謝謝

TOP

pupai

帖子
184 
主題
45 
精華
0 
積分
407 
點名
0  
作業系統
WIN 7 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
註冊時間
2010-8-19 
最後登錄
2024-11-1 

論壇贊助勳章
25#
發表於 2013-11-1 17:05 | 只看該作者
回復 24# GBKEE


    可以了
我先吸收一下
謝謝!!

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
24#
發表於 2013-11-1 16:41 | 只看該作者
回復 23# pupai
應該是在這繼續發問的

附檔試試看對否
text.rar (16.57 KB)
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

pupai

帖子
184 
主題
45 
精華
0 
積分
407 
點名
0  
作業系統
WIN 7 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
註冊時間
2010-8-19 
最後登錄
2024-11-1 

論壇贊助勳章
23#
發表於 2013-11-1 11:03 | 只看該作者

要如何讓Web下載的資料呈現，且同時又可以附帶有Sheet1的版面

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

test.rar (34.26 KB)

test1.rar (29.1 KB)

TOP

pupai

帖子
184 
主題
45 
精華
0 
積分
407 
點名
0  
作業系統
WIN 7 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
註冊時間
2010-8-19 
最後登錄
2024-11-1 

論壇贊助勳章
22#
發表於 2013-10-28 18:13 | 只看該作者
回復 20# GBKEE


    請問G大
我加上巨集後
結果是我要的版面沒錯
但我從Web查詢的資料卻沒有出現
請指導!!   謝謝!!

test.rar (34.26 KB)

TOP

pupai

帖子
184 
主題
45 
精華
0 
積分
407 
點名
0  
作業系統
WIN 7 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
註冊時間
2010-8-19 
最後登錄
2024-11-1 

論壇贊助勳章
21#
發表於 2013-10-23 16:41 | 只看該作者
回復 20# GBKEE


    有勞G大
  感恩!!
PS:原來我可以接著問,謝謝提點

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
20#
發表於 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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

pupai

帖子
184 
主題
45 
精華
0 
積分
407 
點名
0  
作業系統
WIN 7 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
註冊時間
2010-8-19 
最後登錄
2024-11-1 

論壇贊助勳章
19#
發表於 2013-10-23 11:29 | 只看該作者

如何避免當查詢日期 小於 資料日期時 程式中斷

您好
代碼1773的歷史資料從2009/2/27開始有資料
假設我在StartDate打入2006/1/1
當程式執行到1773就會中斷
請問要如何修改
謝謝!!

test.rar (18.45 KB)

TOP

pupai

帖子
184 
主題
45 
精華
0 
積分
407 
點名
0  
作業系統
WIN 7 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
註冊時間
2010-8-19 
最後登錄
2024-11-1 

論壇贊助勳章
18#
發表於 2013-9-22 12:04 | 只看該作者
回復 17# GBKEE


    呵呵....苦笑 我再努力.   受教了

TOP

        靜思自在 : 有心就有福，有願就有力，自造福田，自得福緣。
123
返回列表 上一主題